diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/RadixTreeBench.hs b/bench/RadixTreeBench.hs deleted file mode 100644 --- a/bench/RadixTreeBench.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Main (main) where - -import Control.Arrow -import Control.DeepSeq -import Control.Exception - -import Data.Foldable - -import qualified Data.ByteString.Short as BSS -import qualified Data.HashMap.Strict as HM -import qualified Data.Map.Strict as M -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TLIO - -import qualified Data.HashTable.IO as HT - -import Gauge - -import qualified Data.RadixTree.Internal as RT - -main :: IO () -main = do - let config = defaultConfig - { resamples = 10000 - , displayMode = Condensed - , rerunsLimit = 1 - } - - contents <- TLIO.readFile "/tmp/tags-ebac8dcc87fd1f1b1e7016d6585549309e3c5016-haskell-mode" - let tags :: [TL.Text] - tags = filter (not . TL.null) $ map (head . TL.splitOn "\t") $ drop 1 $ TL.lines contents - - decodeBS = TE.encodeUtf8 . TL.toStrict - decode = BSS.toShort . decodeBS - - tags' :: [BSS.ShortByteString] - tags' = map decode tags - - tags'' :: [(BSS.ShortByteString, ())] - tags'' = map (id &&& const ()) tags' - - tagsRev'' :: [(BSS.ShortByteString, ())] - tagsRev'' = map ((BSS.pack . reverse . BSS.unpack) &&& const ()) tags' - - -- tagsBS :: [(BS.ByteString, ())] - -- tagsBS = map (decodeBS &&& const ()) tags - - queriesPresent :: [BSS.ShortByteString] - queriesPresent = tags' ++ map (BSS.pack . reverse . BSS.unpack) tags' - - queriesMissing :: [BSS.ShortByteString] - queriesMissing = map (BSS.pack . reverse . BSS.unpack) tags' - - queriesBoth :: [BSS.ShortByteString] - queriesBoth = tags' ++ map (BSS.pack . reverse . BSS.unpack) tags' - - evaluate $ rnf tags' - evaluate $ rnf tags'' - evaluate $ rnf tagsRev'' - evaluate $ rnf queriesPresent - evaluate $ rnf queriesMissing - evaluate $ rnf queriesBoth - - let radixTree = RT.fromList tags'' - radixTreeRev = RT.fromList tagsRev'' - treeMap = M.fromList tags'' - treeMapRev = M.fromList tagsRev'' - hashMap = HM.fromList tags'' - hashMapRev = HM.fromList tagsRev'' - - evaluate $ rnf radixTree - evaluate $ rnf radixTreeRev - evaluate $ rnf treeMap - evaluate $ rnf treeMapRev - evaluate $ rnf hashMap - evaluate $ rnf hashMapRev - - (basic :: HT.BasicHashTable BSS.ShortByteString ()) <- HT.new - -- (linear :: HT.LinearHashTable BSS.ShortByteString ()) <- HT.new - (cuckoo :: HT.CuckooHashTable BSS.ShortByteString ()) <- HT.new - for_ tags'' $ \(k, v) -> do - HT.insert basic k v - -- HT.insert linear k v - HT.insert cuckoo k v - - defaultMainWith config - [ bgroup "creation" - [ bench "Data.RadixTree" $ nf RT.fromList tags'' - , bench "Data.Map" $ nf M.fromList tags'' - , bench "Data.HashMap" $ nf HM.fromList tags'' - , bench "BasicHashTable" $ nfIO $ do - (ht :: HT.BasicHashTable BSS.ShortByteString ()) <- HT.new - for_ tags'' $ \(k, v) -> HT.insert ht k v - -- , bench "LinearHashTable" $ nfIO $ do - -- (ht :: HT.LinearHashTable BSS.ShortByteString ()) <- HT.new - -- for_ tags'' $ \(k, v) -> HT.insert ht k v - , bench "CuckooHashTable" $ nfIO $ do - (ht :: HT.CuckooHashTable BSS.ShortByteString ()) <- HT.new - for_ tags'' $ \(k, v) -> HT.insert ht k v - ] - , bgroup "lookup" - [ bgroup "present" - [ bench "Data.RadixTree" $ nf (map (`RT.lookup` radixTree)) queriesPresent - , bench "Data.Map" $ nf (map (`M.lookup` treeMap)) queriesPresent - , bench "Data.HashMap" $ nf (map (`HM.lookup` hashMap)) queriesPresent - , bench "BasicHashTable" $ nfIO $ traverse (HT.lookup basic) queriesPresent - -- , bench "LinearHashTable" $ nfIO $ traverse (HT.lookup linear) queriesPresent - , bench "CuckooHashTable" $ nfIO $ traverse (HT.lookup cuckoo) queriesPresent - ] - , bgroup "missing" - [ bench "Data.RadixTree" $ nf (map (`RT.lookup` radixTree)) queriesMissing - , bench "Data.Map" $ nf (map (`M.lookup` treeMap)) queriesMissing - , bench "Data.HashMap" $ nf (map (`HM.lookup` hashMap)) queriesMissing - , bench "BasicHashTable" $ nfIO $ traverse (HT.lookup basic) queriesMissing - -- , bench "LinearHashTable" $ nfIO $ traverse (HT.lookup linear) queriesMissing - , bench "CuckooHashTable" $ nfIO $ traverse (HT.lookup cuckoo) queriesMissing - ] - , bgroup "both" - [ bench "Data.RadixTree" $ nf (map (`RT.lookup` radixTree)) queriesBoth - , bench "Data.Map" $ nf (map (`M.lookup` treeMap)) queriesBoth - , bench "Data.HashMap" $ nf (map (`HM.lookup` hashMap)) queriesBoth - , bench "BasicHashTable" $ nfIO $ traverse (HT.lookup basic) queriesBoth - -- , bench "LinearHashTable" $ nfIO $ traverse (HT.lookup linear) queriesBoth - , bench "CuckooHashTable" $ nfIO $ traverse (HT.lookup cuckoo) queriesBoth - ] - ] - , bgroup "keys" - [ bench "Data.RadixTree" $ nf RT.keys radixTree - , bench "Data.Map" $ nf M.keys treeMap - , bench "Data.HashMap" $ nf HM.keys hashMap - ] - , bgroup "toList" - [ bench "Data.RadixTree" $ nf RT.toList radixTree - , bench "Data.Map" $ nf M.toList treeMap - , bench "Data.HashMap" $ nf HM.toList hashMap - ] - , bgroup "union" - [ bench "Data.RadixTree" $ nf (uncurry RT.union) (radixTree, radixTreeRev) - , bench "Data.Map" $ nf (uncurry M.union) (treeMap, treeMapRev) - , bench "Data.HashMap" $ nf (uncurry HM.union) (hashMap, hashMapRev) - ] - ] diff --git a/no/No/Set/Word.hs b/no/No/Set/Word.hs new file mode 100644 --- /dev/null +++ b/no/No/Set/Word.hs @@ -0,0 +1,387 @@ +{-# LANGUAGE DerivingStrategies + , GeneralizedNewtypeDeriving + , PatternSynonyms + , ViewPatterns #-} + +module No.Set.Word + ( Color (..) + , other + + , NoSet (Mono, ..) + + , No.Set.Word.lookup + , lookupL + , findL + , lookupR + , findR + + , Range (..) + , monoL + , monoR + , monoRange + + , size + , sizeL + , sizeR + , sizeRange + + , fillL + , fillR + , fillRange + + , No.Set.Word.foldl + , No.Set.Word.foldl' + , No.Set.Word.foldr + , No.Set.Word.foldr' + + , foldlL + , foldlL' + , foldrL + , foldrL' + + , foldlR + , foldlR' + , foldrR + , foldrR' + + , foldlRange + , foldlRange' + , foldrRange + , foldrRange' + + , complement + + , union + , disjoint + , intersection + + , difference + , symmetricDifference + + , PartialOrdering (..) + , No.Set.Word.compare + ) where + + +import Data.Zebra.Word (Color (..), PartialOrdering (..)) +import Data.Zebra.Word.Unsafe (Range (..)) + +import Data.Foldable +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Numeric.Natural + + + +other :: Color -> Color +other Black = White +other White = Black + + + +newtype NoSet = NoSet { getNoSet :: Seq (Color, Word, Word) } + deriving newtype Eq + +instance Show NoSet where + showsPrec _ (NoSet xs) = + showList . fmap (\(_, kL, kR) -> (kL, kR)) + . filter (\(c, _, _) -> c == White) + $ toList xs + +pattern Mono :: Color -> NoSet +pattern Mono c <- (monotone -> Just c) + where + Mono c = NoSet $ Seq.singleton (c, 0, maxBound) + +monotone :: NoSet -> Maybe Color +monotone (NoSet (Seq.Empty Seq.:|> (c, _, _))) = Just c +monotone _ = Nothing + + + +lookup :: Word -> NoSet -> Color +lookup w no = + let ~(NoSet l, _) = unsafeSplitL w no + in case l of + _ :|> (c, _, _) -> c + Empty -> + error $ "No.Set.Word.lookup: out of bounds (" <> shows w ")" + + + +lookupL :: Color -> Word -> NoSet -> Maybe Word +lookupL x w no = + let ~(NoSet l, _) = unsafeSplitL w no + in case l of + _ :|> _ -> go l + Empty -> + error $ "No.Set.Word.lookupL: out of bounds (" <> shows w ")" + + where + go (l :|> (c, _, b)) | c == x = Just b + | otherwise = go l + go Empty = Nothing + +findL :: Word -> Color -> Word -> NoSet -> Word +findL d x w no = + case lookupL x w no of + Just a -> a + Nothing -> d + + + +lookupR :: Color -> Word -> NoSet -> Maybe Word +lookupR x w no = + let ~(_, NoSet r) = unsafeSplitR w no + in case r of + _ :<| _ -> go r + Empty -> + error $ "No.Set.Word.lookupR: out of bounds (" <> shows w ")" + + where + go ((c, a, _) :<| r) | c == x = Just a + | otherwise = go r + go Empty = Nothing + +findR :: Word -> Color -> Word -> NoSet -> Word +findR d x w no = + case lookupR x w no of + Just a -> a + Nothing -> d + + + +monoL :: Word -> NoSet -> Maybe Color +monoL k = monotone . fst . unsafeSplitL k + +monoR :: Word -> NoSet -> Maybe Color +monoR k = monotone . snd . unsafeSplitR k + +monoRange :: Range -> NoSet -> Maybe Color +monoRange r = monotone . (\(_, m, _) -> m) . unsafeSplitRange r + + + +size :: Color -> NoSet -> Natural +size x = + let f (c, a, b) z + | c == x = fromIntegral (b - a) + 1 + z + | otherwise = z + + in Data.Foldable.foldr f 0 . getNoSet + +sizeL :: Color -> Word -> NoSet -> Natural +sizeL x k = size x . fst . unsafeSplitL k + +sizeR :: Color -> Word -> NoSet -> Natural +sizeR x k = size x . snd . unsafeSplitR k + +sizeRange :: Color -> Range -> NoSet -> Natural +sizeRange x r = size x . (\(_, m, _) -> m) . unsafeSplitRange r + + + +fillL :: Word -> Color -> NoSet -> NoSet +fillL w x no = + let ~(_, NoSet _r) = unsafeSplitL w no + in case _r of + (c, _, b) :<| r | c == x -> NoSet $ (c, 0, b) :<| r + | otherwise -> NoSet $ (x, 0, w) :<| _r + + _ -> Mono x + +fillR :: Word -> Color -> NoSet -> NoSet +fillR w x no = + let ~(NoSet _l, _) = unsafeSplitR w no + in case _l of + l :|> (c, a, _) | c == x -> NoSet $ l :|> (c, a, maxBound) + | otherwise -> NoSet $ _l :|> (x, w, maxBound) + + _ -> Mono x + +fillRange :: Range -> Color -> NoSet -> NoSet +fillRange rng@(Range kL kR) x no = + let ~(NoSet _l, _, NoSet _r) = unsafeSplitRange rng no + in case (_l, _r) of + (l :|> (cL, a, _), (cR, _, b) :<| r) -> + case (cL == cR, cL == x) of + (True , True ) -> NoSet $ l <> ((x, a, b) :<| r) + (True , False) -> NoSet $ _l <> ((x, kL, kR) :<| _r) + (False, True ) -> NoSet $ (l :|> (x, a, kR)) <> _r + (False, False) -> NoSet $ _l <> ((x, a, b) :<| r) + + (l :|> (cL, a, _), Empty) + | cL == x -> NoSet $ l :|> (cL, a, maxBound) + | otherwise -> NoSet $ _l :|> (x, kL, maxBound) + + (Empty, (cR, _, b) :<| r) + | cR == x -> NoSet $ (cR, 0, b) :<| r + | otherwise -> NoSet $ (x, 0, kR) :<| _r + + (Empty, Empty) -> Mono x + + + +unsafeSplitL :: Word -> NoSet -> (NoSet, NoSet) +unsafeSplitL k (NoSet xs) = + let ~(_l, r) = Seq.spanl (\(_, a, _) -> a <= k) xs + in case _l of + l :|> (c, a, b) | b > k -> (NoSet $ l :|> (c, a, k), NoSet $ (c, k + 1, b) :<| r) + _ -> (NoSet _l, NoSet r) + +unsafeSplitR :: Word -> NoSet -> (NoSet, NoSet) +unsafeSplitR k (NoSet xs) = + let ~(_r, l) = Seq.spanr (\(_, _, b) -> b >= k) xs + in case _r of + (c, a, b) :<| r | a < k -> (NoSet $ l :|> (c, a, k - 1), NoSet $ (c, k, b) :<| r) + _ -> (NoSet l, NoSet _r) + +unsafeSplitRange :: Range -> NoSet -> (NoSet, NoSet, NoSet) +unsafeSplitRange (Range kL kR) no = + let ~(l, no') = unsafeSplitR kL no + ~(m, r) = unsafeSplitL kR no' + in (l, m, r) + + + +foldl, foldl' :: (a -> Range -> Color -> a) -> a -> NoSet -> a +foldl f z0 = Data.Foldable.foldl (\z (c, a, b) -> f z (UnsafeRange a b) c) z0 . getNoSet +foldl' f z0 = Data.Foldable.foldl' (\z (c, a, b) -> f z (UnsafeRange a b) c) z0 . getNoSet + +foldr, foldr' :: (Range -> Color -> a -> a) -> a -> NoSet -> a +foldr f z0 = Data.Foldable.foldr (\(c, a, b) -> f (UnsafeRange a b) c) z0 . getNoSet +foldr' f z0 = Data.Foldable.foldr' (\(c, a, b) -> f (UnsafeRange a b) c) z0 . getNoSet + + + +foldlL, foldlL' :: Word -> (a -> Range -> Color -> a) -> a -> NoSet -> a +foldlL w f z = No.Set.Word.foldl f z . fst . unsafeSplitL w +foldlL' w f z = No.Set.Word.foldl' f z . fst . unsafeSplitL w + +foldrL, foldrL' :: Word -> (Range -> Color -> a -> a) -> a -> NoSet -> a +foldrL w f z = No.Set.Word.foldr f z . fst . unsafeSplitL w +foldrL' w f z = No.Set.Word.foldr' f z . fst . unsafeSplitL w + + + +foldlR, foldlR' :: Word -> (a -> Range -> Color -> a) -> a -> NoSet -> a +foldlR w f z = No.Set.Word.foldl f z . snd . unsafeSplitR w +foldlR' w f z = No.Set.Word.foldl' f z . snd . unsafeSplitR w + +foldrR, foldrR' :: Word -> (Range -> Color -> a -> a) -> a -> NoSet -> a +foldrR w f z = No.Set.Word.foldr f z . snd . unsafeSplitR w +foldrR' w f z = No.Set.Word.foldr' f z . snd . unsafeSplitR w + + + +foldlRange, foldlRange' :: Range -> (a -> Range -> Color -> a) -> a -> NoSet -> a +foldlRange r f z = No.Set.Word.foldl f z . (\(_, m, _) -> m) . unsafeSplitRange r +foldlRange' r f z = No.Set.Word.foldl' f z . (\(_, m, _) -> m) . unsafeSplitRange r + +foldrRange, foldrRange' :: Range -> (Range -> Color -> a -> a) -> a -> NoSet -> a +foldrRange r f z = No.Set.Word.foldr f z . (\(_, m, _) -> m) . unsafeSplitRange r +foldrRange' r f z = No.Set.Word.foldr' f z . (\(_, m, _) -> m) . unsafeSplitRange r + + + +-- | Combines two sets into an ascending non-overlapping list of +-- consecutive double-colored ranges. +-- +-- Both sets must be defined over the same ranges for this function to make sense. +crush :: NoSet -> NoSet -> [(Color, Range, Color)] +crush (NoSet xs) (NoSet ys) = go xs ys + where + go Empty Empty = [] + go ((cL, aL, bL) :<| l) ((cR, aR, bR) :<| r) = + case bL `Prelude.compare` bR of + LT -> (cL, UnsafeRange aL bL, cR) : go l ((cR, bL + 1, bR) :<| r) + GT -> (cL, UnsafeRange aR bR, cR) : go ((cL, bR + 1, bL) :<| l) r + EQ -> (cL, UnsafeRange aL bL, cR) : go l r + + go _ _ = + error "No.Set.Word.crush: unequally sized sets" + + + +complement :: NoSet -> NoSet +complement = NoSet . fmap (\(c, a, b) -> (other c, a, b)) . getNoSet + + + +union :: Color -> NoSet -> NoSet -> NoSet +union x = + merge $ \cL cR -> + if cL == cR && cL /= x + then cL + else x + +disjoint :: Color -> NoSet -> NoSet -> Bool +disjoint x a b = + case intersection x a b of + Mono y -> x /= y + _ -> False + +intersection :: Color -> NoSet -> NoSet -> NoSet +intersection x = + merge $ \cL cR -> + if cL == cR && cL == x + then x + else other x + +difference :: Color -> NoSet -> NoSet -> NoSet +difference x = + merge $ \cL cR -> + if cL /= cR && cL == x + then x + else other x + +symmetricDifference :: Color -> NoSet -> NoSet -> NoSet +symmetricDifference x = + merge $ \cL cR -> + if cL == cR + then other x + else x + + + + +data Carry = Carry Color Word + | NoCarry + +merge :: (Color -> Color -> Color) -> NoSet -> NoSet -> NoSet +merge f as bs = NoSet . Seq.fromList . unify NoCarry $ crush as bs + where + unify carry [] = + case carry of + NoCarry -> [] + Carry c k -> (c, k, maxBound) : [] + + unify carry ((cL, Range a _, cR) : rest) = + let cM = f cL cR + in case carry of + NoCarry -> unify (Carry cM a) rest + Carry c k + | c == cM -> unify carry rest + | otherwise -> (c, k, a - 1) : unify (Carry cM a) rest + + + +compare :: Color -> NoSet -> NoSet -> PartialOrdering +compare x as bs = Data.Foldable.foldr go Equal $ crush as bs + where + go (cL, _, cR) p = + case p of + Subset + | cL == cR || cR == x -> Subset + | otherwise -> Incomparable + + Superset + | cL == cR || cL == x -> Superset + | otherwise -> Incomparable + + Equal + | cL == cR -> Equal + | cR == x -> Subset + | otherwise -> Superset + + Incomparable -> Incomparable diff --git a/no/No/Tree.hs b/no/No/Tree.hs new file mode 100644 --- /dev/null +++ b/no/No/Tree.hs @@ -0,0 +1,632 @@ +{-# LANGUAGE DerivingStrategies + , GeneralizedNewtypeDeriving + , PatternSynonyms #-} + +module No.Tree + ( NoTree + , empty + , singleton + + , No.Tree.null + + , fromList + , No.Tree.toList + + , No.Tree.map + , mapWithKey + + , size + , No.Tree.foldl + , foldlWithKey + , No.Tree.foldr + , foldrWithKey + , No.Tree.foldMap + , foldMapWithKey + + , No.Tree.traverse + , traverseWithKey + + , No.Tree.lookup + , find + , member + + , prefix + , subtree + + , insert + , insertWith + , adjust + , delete + , update + , alter + + , prune + , shape + + , Openness (..) + , lookupL + , adjustL + , adjustLWithKey + , deleteL + , updateL + , updateLWithKey + , takeL + + , lookupR + , adjustR + , adjustRWithKey + , deleteR + , updateR + , updateRWithKey + , takeR + + , Range (WordRange, StringRange, ..) + , adjustRange + , adjustRangeWithKey + , deleteRange + , updateRange + , updateRangeWithKey + , takeRange + + , unionL + , unionWithKey + + , difference + , differenceWithKey + + , intersectionL + , intersectionWithKey + + , No.Tree.compare + + , splitL + , splitR + , splitLookup + + , No.Tree.filter + , filterWithKey + + , No.Tree.mapMaybe + , mapMaybeWithKey + + , partition + , partitionWithKey + + , mapEither + , mapEitherWithKey + + , lookupMin + , lookupMinWithKey + , lookupMax + , lookupMaxWithKey + + , adjustMin + , adjustMinWithKey + , adjustMax + , adjustMaxWithKey + + , deleteMin + , deleteMax + + , updateMin + , updateMinWithKey + , updateMax + , updateMaxWithKey + + , minView + , maxView + ) where + +import Data.Patricia.Word.Strict (PartialOrdering (..)) +import Data.RadixTree.Word8.Strict (Openness (..)) + +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as Seq +import Data.Maybe +import Data.Either +import Data.Foldable (toList) +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty + + + +newtype NoTree k a = NoTree { getNoTree :: Seq (k, a) } + deriving newtype (Show, Eq) + +empty :: NoTree k a +empty = NoTree Seq.empty + +singleton :: k -> a -> NoTree k a +singleton k a = NoTree $ Seq.singleton (k, a) + + +null :: NoTree k a -> Bool +null = Seq.null . getNoTree + + + +fromList :: Ord k => [(k, a)] -> NoTree k a +fromList = NoTree . Seq.fromList . List.nubBy (\(k, _) (l, _) -> k == l) . List.sortOn fst + +toList :: NoTree k a -> [(k, a)] +toList (NoTree as) = Data.Foldable.toList as + + + +map :: (a -> b) -> NoTree k a -> NoTree k b +map f = mapWithKey (\_ -> f) + +mapWithKey :: (k -> a -> b) -> NoTree k a -> NoTree k b +mapWithKey f (NoTree as) = NoTree $ fmap (\(ks, a) -> (ks, f ks a)) as + + +size :: NoTree k a -> Int +size = No.Tree.foldr (\_ -> (+) 1) 0 + +foldl :: (b -> a -> b) -> b -> NoTree k a -> b +foldl f = foldlWithKey (\z _ -> f z) + +foldlWithKey :: (b -> k -> a -> b) -> b -> NoTree k a -> b +foldlWithKey f z (NoTree as) = Prelude.foldl (\z' (ks, a) -> f z' ks a) z as + +foldr :: (a -> b -> b) -> b -> NoTree k a -> b +foldr f = foldrWithKey (\_ -> f) + +foldrWithKey :: (k -> a -> b -> b) -> b -> NoTree k a -> b +foldrWithKey f z (NoTree as) = Prelude.foldr (\(ks, a) -> f ks a) z as + +foldMap :: Monoid m => (a -> m) -> NoTree k a -> m +foldMap f = foldMapWithKey (\_ -> f) + +foldMapWithKey :: Monoid m => (k -> a -> m) -> NoTree k a -> m +foldMapWithKey f (NoTree as) = Prelude.foldMap (\(ks, a) -> f ks a) as + +traverse :: Applicative f => (a -> f b) -> NoTree k a -> f (NoTree k b) +traverse f = traverseWithKey (\_ -> f) + +traverseWithKey + :: Applicative f => (k -> a -> f b) -> NoTree k a -> f (NoTree k b) +traverseWithKey f (NoTree as) = + NoTree <$> Prelude.traverse (\(ks, a) -> (,) ks <$> f ks a) as + + + +lookup :: Ord k => k -> NoTree k a -> Maybe a +lookup k = (\(_, mx, _) -> mx) <$> splitLookup k + +find :: Ord k => a -> k -> NoTree k a -> a +find d k = (\(_, mx, _) -> fromMaybe d mx) <$> splitLookup k + +member :: Ord k => k -> NoTree k a -> Bool +member k = (\(_, mx, _) -> maybe False (\_ -> True) mx) <$> splitLookup k + + + +subtree :: Ord k => [k] -> NoTree [k] a -> NoTree [k] a +subtree ks (NoTree as) = + let (_, bs) = Seq.spanl (\(w, _) -> not $ List.isPrefixOf ks w) as + (cs, _) = Seq.spanl (\(w, _) -> List.isPrefixOf ks w) bs + + in NoTree $ fmap (\(k, a) -> (drop (length ks) k, a)) cs + +prefix :: [k] -> NoTree [k] a -> NoTree [k] a +prefix k (NoTree as) = NoTree $ fmap (\(w, a) -> (k <> w, a)) as + + + +insert :: Ord k => k -> a -> NoTree k a -> NoTree k a +insert k a = alter (\_ -> Just a) k + +insertWith :: Ord k => (a -> a) -> k -> a -> NoTree k a -> NoTree k a +insertWith f k a = alter (Just . maybe a f) k + +adjust :: Ord k => (a -> a) -> k -> NoTree k a -> NoTree k a +adjust f = alter (fmap f) + +delete :: Ord k => k -> NoTree k a -> NoTree k a +delete k = alter (\_ -> Nothing) k + +update :: Ord k => (a -> Maybe a) -> k -> NoTree k a -> NoTree k a +update f k = alter (f =<<) k + +alter :: Ord k => (Maybe a -> Maybe a) -> k -> NoTree k a -> NoTree k a +alter f k no = + let ~(NoTree as, mx, NoTree bs) = splitLookup k no + in case f mx of + Just y -> NoTree $ as <> ((k, y) :<| bs) + Nothing -> NoTree $ as <> bs + + + +prune :: Ord k => Openness -> [k] -> NoTree [k] a -> NoTree [k] a +prune o ks xs = + let (NoTree ls, NoTree ms, NoTree rs) = breakOnPrefix ks xs + + in NoTree $ ls <> case ms of + (x, y) :<| _ | x == ks, Open <- o -> (x, y) :<| rs + _ -> rs + +shape :: Ord k => (NoTree [k] a -> NoTree [k] a) -> [k] -> NoTree [k] a -> NoTree [k] a +shape f ks xs = + let (NoTree ls, NoTree ms, NoTree rs) = breakOnPrefix ks xs + + NoTree ms' = f . NoTree $ fmap (\(k, a) -> (drop (length ks) k, a)) ms + + in NoTree $ ls <> fmap (\(k, a) -> (ks <> k, a)) ms' <> rs + +breakOnPrefix :: Ord k => [k] -> NoTree [k] a -> (NoTree [k] a, NoTree [k] a, NoTree [k] a) +breakOnPrefix ks (NoTree xs) = + let ~(as, bs) = Seq.spanl (\(ws, _) -> take (length ks) ws < ks) xs + ~(cs, ds) = Seq.spanl (\(ws, _) -> List.isPrefixOf ks ws) bs + + in (NoTree as, NoTree cs, NoTree ds) + + + +lookupL :: Ord k => Openness -> k -> NoTree k a -> Maybe (k, a) +lookupL o k no = + let NoTree as = takeL o k no + in case as of + _ :|> ka -> Just ka + Seq.Empty -> Nothing + +adjustL :: Ord k => (a -> a) -> Openness -> k -> NoTree k a -> NoTree k a +adjustL f = shapeL (No.Tree.map f) + +adjustLWithKey :: Ord k => (k -> a -> a) -> Openness -> k -> NoTree k a -> NoTree k a +adjustLWithKey f = shapeL (mapWithKey f) + +deleteL :: Ord k => Openness -> k -> NoTree k a -> NoTree k a +deleteL = shapeL (\_ -> empty) + +updateL :: Ord k => (a -> Maybe a) -> Openness -> k -> NoTree k a -> NoTree k a +updateL f = shapeL (No.Tree.mapMaybe f) + +updateLWithKey :: Ord k => (k -> a -> Maybe a) -> Openness -> k -> NoTree k a -> NoTree k a +updateLWithKey f = shapeL (mapMaybeWithKey f) + +takeL :: Ord k => Openness -> k -> NoTree k a -> NoTree k a +takeL Closed = deleteR Open +takeL Open = deleteR Closed + +shapeL :: Ord k => (NoTree k a -> NoTree k a) -> Openness -> k -> NoTree k a -> NoTree k a +shapeL f o k no = + let ~(NoTree as, mx, NoTree bs) = splitLookup k no + in case mx of + Nothing -> NoTree $ getNoTree (f $ NoTree as) <> bs + Just x -> + case o of + Closed -> NoTree $ getNoTree (f $ NoTree (as :|> (k, x))) <> bs + Open -> NoTree $ getNoTree (f $ NoTree as) <> ((k, x) :<| bs) + + + +lookupR :: Ord k => Openness -> k -> NoTree k a -> Maybe (k, a) +lookupR o k no = + let NoTree as = takeR o k no + in case as of + ka :<| _ -> Just ka + Seq.Empty -> Nothing + +adjustR :: Ord k => (a -> a) -> Openness -> k -> NoTree k a -> NoTree k a +adjustR f = shapeR (No.Tree.map f) + +adjustRWithKey :: Ord k => (k -> a -> a) -> Openness -> k -> NoTree k a -> NoTree k a +adjustRWithKey f = shapeR (mapWithKey f) + +deleteR :: Ord k => Openness -> k -> NoTree k a -> NoTree k a +deleteR = shapeR (\_ -> empty) + +updateR :: Ord k => (a -> Maybe a) -> Openness -> k -> NoTree k a -> NoTree k a +updateR f = shapeR (No.Tree.mapMaybe f) + +updateRWithKey :: Ord k => (k -> a -> Maybe a) -> Openness -> k -> NoTree k a -> NoTree k a +updateRWithKey f = shapeR (mapMaybeWithKey f) + +takeR :: Ord k => Openness -> k -> NoTree k a -> NoTree k a +takeR Closed = deleteL Open +takeR Open = deleteL Closed + +shapeR :: Ord k => (NoTree k a -> NoTree k a) -> Openness -> k -> NoTree k a -> NoTree k a +shapeR f o k no = + let ~(NoTree as, mx, NoTree bs) = splitLookup k no + in case mx of + Nothing -> NoTree $ as <> getNoTree (f $ NoTree bs) + Just x -> + case o of + Closed -> NoTree $ as <> getNoTree (f . NoTree $ (k, x) :<| bs) + Open -> NoTree $ (as :|> (k, x)) <> getNoTree (f $ NoTree bs) + + + +data Range k = UnsafeRange + {-# UNPACK #-} !Openness + k + {-# UNPACK #-} !Openness + k + +instance Show k => Show (Range k) where + showsPrec d (UnsafeRange oL kL oR kR) = + showParen (d > 10) $ + showString "Range " . shows oL + . showChar ' ' . shows kL + . showChar ' ' . shows oR + . showChar ' ' . shows kR + +pattern WordRange + :: (Bounded k, Num k, Ord k) + => Openness + -> k + -> Openness + -> k + -> Range k +pattern WordRange oL kL oR kR <- UnsafeRange oL kL oR kR + where + WordRange o1 k1 o2 k2 = + case Prelude.compare k1 k2 of + LT -> UnsafeRange o1 k1 o2 k2 + GT -> UnsafeRange o2 k2 o1 k1 + EQ -> + let o | Closed <- o1, Closed <- o2 = Closed + | otherwise = Open + + in if k1 == maxBound + then UnsafeRange Open (maxBound - 1) o maxBound + else UnsafeRange o k1 Open (k1 + 1) + +pattern StringRange + :: (Bounded k, Ord k, Num k) + => Openness + -> NonEmpty k + -> Openness + -> NonEmpty k + -> Range (NonEmpty k) +pattern StringRange oL kL oR kR <- UnsafeRange oL kL oR kR + where + StringRange o1 k1 o2 k2 = + case Prelude.compare k1 k2 of + LT -> UnsafeRange o1 k1 o2 k2 + GT -> UnsafeRange o2 k2 o1 k1 + EQ -> + let o | Closed <- o1, Closed <- o2 = Closed + | otherwise = Open + + x = NonEmpty.last k1 + xs = NonEmpty.init k1 + + in if x == maxBound + then UnsafeRange Open (NonEmpty.fromList $ xs <> [x - 1]) o k1 + else UnsafeRange o k1 Open (NonEmpty.fromList $ xs <> [x + 1]) + + + +adjustRange :: Ord k => (a -> a) -> Range k -> NoTree k a -> NoTree k a +adjustRange f = shapeRange (No.Tree.map f) + +adjustRangeWithKey :: Ord k => (k -> a -> a) -> Range k -> NoTree k a -> NoTree k a +adjustRangeWithKey f = shapeRange (mapWithKey f) + +deleteRange :: Ord k => Range k -> NoTree k a -> NoTree k a +deleteRange = shapeRange (\_ -> empty) + +updateRange :: Ord k => (a -> Maybe a) -> Range k -> NoTree k a -> NoTree k a +updateRange f = shapeRange (No.Tree.mapMaybe f) + +updateRangeWithKey :: Ord k => (k -> a -> Maybe a) -> Range k -> NoTree k a -> NoTree k a +updateRangeWithKey f = shapeRange (mapMaybeWithKey f) + +takeRange :: Ord k => Range k -> NoTree k a -> NoTree k a +takeRange (UnsafeRange oL kL oR kR) = takeR oL kL . takeL oR kR + +shapeRange :: Ord k => (NoTree k a -> NoTree k a) -> Range k -> NoTree k a -> NoTree k a +shapeRange f (UnsafeRange oL kL oR kR) = shapeR (shapeL f oR kR) oL kL + + + +merge + :: Ord k + => (k -> a -> b -> Maybe c) + -> (a -> Maybe c) + -> (b -> Maybe c) + -> NoTree k a + -> NoTree k b + -> NoTree k c +merge f l r (NoTree as) (NoTree bs) = + NoTree . Seq.fromList $ go (Data.Foldable.toList as) (Data.Foldable.toList bs) + where + go ((ks, x) : xs) ((ls, y) : ys) = + case Prelude.compare ks ls of + LT -> let rest = go xs ((ls, y) : ys) + in case l x of + Just z -> (ks, z) : rest + Nothing -> rest + + EQ -> let rest = go xs ys + in case f ks x y of + Just z -> (ks, z) : rest + Nothing -> rest + + GT -> let rest = go ((ks, x) : xs) ys + in case r y of + Just z -> (ls, z) : rest + Nothing -> rest + + go xs [] = Data.Maybe.mapMaybe (\(ks, x) -> (,) ks <$> l x) xs + go [] ys = Data.Maybe.mapMaybe (\(ls, y) -> (,) ls <$> r y) ys + + + +unionL :: Ord k => NoTree k a -> NoTree k a -> NoTree k a +unionL = unionWithKey (\_ a _ -> a) + +unionWithKey + :: Ord k => (k -> a -> a -> a) -> NoTree k a -> NoTree k a -> NoTree k a +unionWithKey f = merge (\ks a b -> Just $ f ks a b) Just Just + + +difference :: Ord k => NoTree k a -> NoTree k b -> NoTree k a +difference = differenceWithKey (\_ _ _ -> Nothing) + +differenceWithKey + :: Ord k => (k -> a -> b -> Maybe a) -> NoTree k a -> NoTree k b -> NoTree k a +differenceWithKey f = merge f Just (\_ -> Nothing) + + +intersectionL :: Ord k => NoTree k a -> NoTree k b -> NoTree k a +intersectionL = intersectionWithKey (\_ a _ -> a) + +intersectionWithKey + :: Ord k => (k -> a -> b -> c) -> NoTree k a -> NoTree k b -> NoTree k c +intersectionWithKey f = + merge (\k a b -> Just $ f k a b) (\_ -> Nothing) (\_ -> Nothing) + + + +compare :: (Eq a, Ord k) => NoTree k a -> NoTree k a -> PartialOrdering +compare xs@(NoTree as) ys@(NoTree bs) + | as == bs = Equal + + | NoTree is <- intersectionL xs ys, is == as + , NoTree us <- unionL xs ys, us == bs = Subset + + | NoTree is <- intersectionL xs ys, is == bs + , NoTree us <- unionL xs ys, us == as = Superset + + | otherwise = Incomparable + + + +splitL :: Ord k => Openness -> k -> NoTree k a -> (NoTree k a, NoTree k a) +splitL o k t = + let (NoTree l, mx, NoTree r) = splitLookup k t + in case mx of + Just x -> case o of + Closed -> (NoTree $ l :|> (k, x), NoTree r) + Open -> (NoTree $ l, NoTree $ (k, x) :<| r) + + Nothing -> (NoTree l, NoTree r) + +splitR :: Ord k => k -> NoTree k a -> (NoTree k a, NoTree k a) +splitR k t = + let (l, mx, NoTree r) = splitLookup k t + in ( l + , NoTree $ case mx of + Just x -> (k, x) :<| r + Nothing -> r + ) + +splitLookup :: Ord k => k -> NoTree k a -> (NoTree k a, Maybe a, NoTree k a) +splitLookup ws (NoTree as) = + let (before, after) = Seq.spanl (\(ks, _) -> ks < ws) as + in case after of + (cs, a) :<| rest | cs == ws -> (NoTree before, Just a , NoTree rest) + _ -> (NoTree before, Nothing, NoTree after) + + + +filter :: (a -> Bool) -> NoTree k a -> NoTree k a +filter f = fst . partition f + +filterWithKey :: (k -> a -> Bool) -> NoTree k a -> NoTree k a +filterWithKey f = fst . partitionWithKey f + +mapMaybe :: (a -> Maybe b) -> NoTree k a -> NoTree k b +mapMaybe f = fst . mapEitherWithKey (\_ -> maybe (Right ()) Left . f) + +mapMaybeWithKey :: (k -> a -> Maybe b) -> NoTree k a -> NoTree k b +mapMaybeWithKey f = fst . mapEitherWithKey (\ks -> maybe (Right ()) Left . f ks) + +partition :: (a -> Bool) -> NoTree k a -> (NoTree k a, NoTree k a) +partition f = mapEitherWithKey (\_ a -> if f a then Left a else Right a) + +partitionWithKey :: (k -> a -> Bool) -> NoTree k a -> (NoTree k a, NoTree k a) +partitionWithKey f = mapEitherWithKey (\ks a -> if f ks a then Left a else Right a) + +mapEither :: (a -> Either b c) -> NoTree k a -> (NoTree k b, NoTree k c) +mapEither f = mapEitherWithKey (\_ -> f) + +mapEitherWithKey + :: (k -> a -> Either b c) -> NoTree k a -> (NoTree k b, NoTree k c) +mapEitherWithKey f (NoTree as) = + let ~(bs, cs) = partitionEithers $ + flip fmap (Data.Foldable.toList as) $ \(ks, a) -> + case f ks a of + Left b -> Left (ks, b) + Right c -> Right (ks, c) + + in (NoTree $ Seq.fromList bs, NoTree $ Seq.fromList cs) + + + +lookupMin :: NoTree k a -> Maybe a +lookupMin t = (\ (_, a, _) -> a) <$> minView t + +lookupMinWithKey :: NoTree k a -> Maybe (k, a) +lookupMinWithKey t = (\ (k, a, _) -> (k, a)) <$> minView t + +deleteMin :: NoTree k a -> NoTree k a +deleteMin = updateMin (\_ -> Nothing) + +adjustMin :: (a -> a) -> NoTree k a -> NoTree k a +adjustMin f = adjustMinWithKey (\_ -> f) + +adjustMinWithKey :: (k -> a -> a) -> NoTree k a -> NoTree k a +adjustMinWithKey f = updateMinWithKey (\k a -> Just $ f k a) + +updateMin :: (a -> Maybe a) -> NoTree k a -> NoTree k a +updateMin f = updateMinWithKey (\_ -> f) + +updateMinWithKey :: (k -> a -> Maybe a) -> NoTree k a -> NoTree k a +updateMinWithKey f (NoTree as) = + NoTree $ + case as of + (k, a) :<| bs -> + case f k a of + Just b -> (k, b) :<| bs + Nothing -> bs + + Empty -> Seq.empty + +minView :: NoTree k a -> Maybe (k, a, NoTree k a) +minView (NoTree as) = + case as of + (k, a) :<| bs -> Just (k, a, NoTree bs) + Empty -> Nothing + + + +lookupMax :: NoTree k a -> Maybe a +lookupMax t = (\ (_, _, a) -> a) <$> maxView t + +lookupMaxWithKey :: NoTree k a -> Maybe (k, a) +lookupMaxWithKey t = (\ (_, k, a) -> (k, a)) <$> maxView t + +deleteMax :: NoTree k a -> NoTree k a +deleteMax = updateMax (\_ -> Nothing) + +adjustMax :: (a -> a) -> NoTree k a -> NoTree k a +adjustMax f = adjustMaxWithKey (\_ -> f) + +adjustMaxWithKey :: (k -> a -> a) -> NoTree k a -> NoTree k a +adjustMaxWithKey f = updateMaxWithKey (\k a -> Just $ f k a) + +updateMax :: (a -> Maybe a) -> NoTree k a -> NoTree k a +updateMax f = updateMaxWithKey (\_ -> f) + +updateMaxWithKey :: (k -> a -> Maybe a) -> NoTree k a -> NoTree k a +updateMaxWithKey f (NoTree as) = + NoTree $ + case as of + bs :|> (k, a) -> + case f k a of + Just b -> bs :|> (k, b) + Nothing -> bs + + Empty -> Seq.empty + +maxView :: NoTree k a -> Maybe (NoTree k a, k, a) +maxView (NoTree as) = + case as of + bs :|> (k, a) -> Just (NoTree bs, k, a) + Empty -> Nothing diff --git a/radix-tree.cabal b/radix-tree.cabal --- a/radix-tree.cabal +++ b/radix-tree.cabal @@ -1,143 +1,144 @@ -name: - radix-tree -version: - 0.1 -category: - Data Structures -synopsis: - Radix tree data structive over short byte-strings -description: - This module provides a memory-efficient map from - Data.ByteString.Short keys to arbitrary values implemented as a radix - tree datastructure. Memory efficiency is achieved by sharing common - prefixes of all keys. -license: - BSD3 -license-file: - LICENSE -author: - Sergey Vinokurov -maintainer: - Sergey Vinokurov -copyright: - (c) 2018 Sergey Vinokurov -tested-with: - GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3 +name: radix-tree +version: 1.0.0.0 -cabal-version: - 2.0 -build-type: - Simple +category: Data Structures +synopsis: Radix trees. +description: Radix and PATRICIA trees, both spine-strict and spine-lazy. -homepage: https://github.com/sergv/radix-tree +license: BSD3 +license-file: LICENSE +author: Sergey Vinokurov, Oleksii Divak +maintainer: Oleksii Divak +copyright: (c) 2018 Sergey Vinokurov + +cabal-version: 2.0 +build-type: Simple + +homepage: https://github.com/sergv/radix-tree + source-repository head - type: git - location: https://github.com/sergv/radix-tree.git + type: git + location: https://github.com/sergv/radix-tree.git library - exposed-modules: - Data.RadixTree - Data.RadixTree.Internal - hs-source-dirs: - src - build-depends: - base >= 4.9 && < 5, - bytestring, - containers, - deepseq, - primitive - default-language: - Haskell2010 - ghc-options: - -Wall - -fwarn-name-shadowing - -fno-warn-type-defaults - if impl(ghc >= 8.0) - ghc-options: - -Wcompat - -Whi-shadowing - -Widentities - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wmissing-exported-signatures - if impl(ghc >= 8.2) - ghc-options: - -Wcpp-undef - -Wmissing-home-modules - -Wunbanged-strict-patterns + exposed-modules: Data.Patricia.Word.Lazy + Data.Patricia.Word.Lazy.Debug + Data.Patricia.Word.Lazy.TH + Data.Patricia.Word.Lazy.Unsafe + Data.Patricia.Word.Strict + Data.Patricia.Word.Strict.Debug + Data.Patricia.Word.Strict.TH + Data.Patricia.Word.Strict.Unsafe -test-suite radix-tree-test - type: - exitcode-stdio-1.0 - main-is: - test/TestMain.hs - build-depends: - HUnit, - QuickCheck, - base >= 4.9 && < 5, - bytestring, - containers, - tasty, - tasty-hunit, - tasty-quickcheck, - radix-tree - default-language: - Haskell2010 - ghc-options: - -rtsopts - -Wall - -fwarn-name-shadowing - -fno-warn-type-defaults - if impl(ghc >= 8.0) - ghc-options: - -Wall-missed-specialisations - -Wcompat - -Whi-shadowing - -Widentities - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wmissing-exported-signatures - if impl(ghc >= 8.2) - ghc-options: - -Wcpp-undef - -Wmissing-home-modules - -Wunbanged-strict-patterns + Data.RadixTree.Word8.Key + Data.RadixTree.Word8.Key.Unsafe + Data.RadixTree.Word8.Lazy + Data.RadixTree.Word8.Lazy.Debug + Data.RadixTree.Word8.Lazy.TH + Data.RadixTree.Word8.Lazy.Unsafe + Data.RadixTree.Word8.Strict + Data.RadixTree.Word8.Strict.Debug + Data.RadixTree.Word8.Strict.TH + Data.RadixTree.Word8.Strict.Unsafe -benchmark radix-tree-bench - type: - exitcode-stdio-1.0 - main-is: - bench/RadixTreeBench.hs - hs-source-dirs: - . bench - build-depends: - base >= 4.9 && < 5, - bytestring, - containers, - deepseq, - gauge >= 0.2.3, - hashtables, - radix-tree, - text, - unordered-containers - default-language: - Haskell2010 - ghc-options: - -rtsopts - -Wall - -fwarn-name-shadowing - -fno-warn-type-defaults - if impl(ghc >= 8.0) - ghc-options: - -Wcompat - -Whi-shadowing - -Widentities - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wmissing-exported-signatures - if impl(ghc >= 8.2) - ghc-options: - -Wcpp-undef - -Wmissing-home-modules - -Wunbanged-strict-patterns + Data.Radix1Tree.Word8.Key + Data.Radix1Tree.Word8.Key.Unsafe + Data.Radix1Tree.Word8.Lazy + Data.Radix1Tree.Word8.Lazy.Debug + Data.Radix1Tree.Word8.Lazy.TH + Data.Radix1Tree.Word8.Lazy.Unsafe + Data.Radix1Tree.Word8.Strict + Data.Radix1Tree.Word8.Strict.Debug + Data.Radix1Tree.Word8.Strict.TH + Data.Radix1Tree.Word8.Strict.Unsafe + + Data.Zebra.Word + Data.Zebra.Word.Debug + Data.Zebra.Word.Unsafe + + other-modules: Data.ByteArray.NonEmpty + + Data.Patricia.Word.Common + Data.Patricia.Word.Conversion + Data.Patricia.Word.Debug + Data.Patricia.Word.Lazy.Internal + Data.Patricia.Word.Strict.Internal + + Data.RadixNTree.Word8.Common + Data.RadixNTree.Word8.Conversion + Data.RadixNTree.Word8.Debug + Data.RadixNTree.Word8.Key + Data.RadixNTree.Word8.Lazy + Data.RadixNTree.Word8.Lazy.Debug + Data.RadixNTree.Word8.Lazy.TH + Data.RadixNTree.Word8.Strict + Data.RadixNTree.Word8.Strict.Debug + Data.RadixNTree.Word8.Strict.TH + + Data.Zebra.Word.Internal + + Numeric.Long + + Radix.Common + Radix.Exception + Radix.Word8.Common + Radix.Word8.Debug + Radix.Word8.Foundation + Radix.Word.Common + Radix.Word.Debug + Radix.Word.Foundation + + hs-source-dirs: src + + build-depends: base >= 4.12 && < 5 + , bytestring >= 0.10.4 && < 0.13 + , deepseq >= 1.4.3 && < 1.6 + , primitive >= 0.7 && < 0.10 + , template-haskell >= 2.17 && < 3 + , text >= 2.0 && < 2.2 + + default-language: Haskell2010 + + ghc-options: -Wall + +test-suite properties + type: exitcode-stdio-1.0 + + main-is: Main.hs + + other-modules: No.Set.Word + No.Tree + + Test.Kit + + Test.Patricia.Word.Lazy + Test.Patricia.Word.Sample + Test.Patricia.Word.Strict + + Test.RadixNTree.Word8.Key + Test.RadixNTree.Word8.Sample + + Test.RadixTree.Word8.Lazy + Test.RadixTree.Word8.Strict + + Test.Random + + Test.Zebra.Word + Test.Zebra.Word.Sample + + hs-source-dirs: no + , test/properties + + ghc-options: -Wall + + build-depends: base + , bytestring + , containers >= 0.5 && < 0.8 + , hspec >= 2 && < 3 + , primitive + , radix-tree + , random >= 1.2.0 && < 1.3 + , text + + default-language: Haskell2010 diff --git a/src/Data/ByteArray/NonEmpty.hs b/src/Data/ByteArray/NonEmpty.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteArray/NonEmpty.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE BangPatterns + , RankNTypes + , ScopedTypeVariables + , UnboxedTuples #-} + +module Data.ByteArray.NonEmpty + ( Step (..) + + , fromStep + , toNonEmpty + , toList + + , dropByteArray + + , appendByteArray + , dropAppendByteArray + , fromStepAppend + + , splitByteArray + ) where + +import Control.Monad.ST +import Data.Primitive.ByteArray +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Word + + + +-- | Single step of destroying a key. +data Step a b = More a b + | Done + +{-# INLINE fromStep #-} +fromStep :: (x -> Step Word8 x) -> Word8 -> x -> ByteArray +fromStep (more :: x -> Step Word8 x) = \w0 -> go 1 (\marr -> writeByteArray marr 0 w0) + where + go :: Int -> (forall s. MutableByteArray s -> ST s ()) -> x -> ByteArray + go !n write s = + case more s of + More w s' -> + let write' marr = do + write marr + writeByteArray marr n w + + in go (n + 1) write' s' + + Done -> + runST $ do + marr <- newByteArray n + write marr + unsafeFreezeByteArray marr + + + +{-# INLINE toNonEmpty #-} +toNonEmpty :: ByteArray -> NonEmpty Word8 +toNonEmpty arr = indexByteArray arr 0 :| toListFrom 1 arr + +{-# INLINE toList #-} +toList :: ByteArray -> [Word8] +toList = toListFrom 0 + +{-# INLINE toListFrom #-} +toListFrom :: Int -> ByteArray -> [Word8] +toListFrom n0 arr = go n0 + where + go n + | n >= sizeofByteArray arr = [] + | otherwise = indexByteArray arr n : go (n + 1) + + + +dropByteArray :: Int -> ByteArray -> ByteArray +dropByteArray n arr = + runST $ do + let len = sizeofByteArray arr - n + mbrr <- newByteArray len + copyByteArray mbrr 0 arr n len + unsafeFreezeByteArray mbrr + + + +appendByteArray :: ByteArray -> ByteArray -> ByteArray +appendByteArray arr brr = + runST $ do + let alen = sizeofByteArray arr + blen = sizeofByteArray brr + mcrr <- newByteArray (alen + blen) + copyByteArray mcrr 0 arr 0 alen + copyByteArray mcrr alen brr 0 blen + unsafeFreezeByteArray mcrr + + + +dropAppendByteArray :: Int -> ByteArray -> ByteArray -> ByteArray +dropAppendByteArray n arr brr = + runST $ do + let alen = sizeofByteArray arr - n + blen = sizeofByteArray brr + mcrr <- newByteArray (alen + blen) + copyByteArray mcrr 0 arr n alen + copyByteArray mcrr alen brr 0 blen + unsafeFreezeByteArray mcrr + + + +{-# INLINE fromStepAppend #-} +fromStepAppend :: (x -> Step Word8 x) -> Word8 -> x -> ByteArray -> ByteArray +fromStepAppend (more :: x -> Step Word8 x) = \w0 s0 arr -> + let go :: Int -> (forall s. MutableByteArray s -> ST s ()) -> x -> ByteArray + go !n write s = + case more s of + More w s' -> + let write' mbrr = do + writeByteArray mbrr n w + write mbrr + + in go (n + 1) write' s' + + Done -> + runST $ do + let alen = sizeofByteArray arr + mbrr <- newByteArray (n + alen) + write mbrr + copyByteArray mbrr n arr 0 alen + unsafeFreezeByteArray mbrr + + in go 1 (\mbrr -> writeByteArray mbrr 0 w0) s0 + + + +data Wrap = Wrap {-# UNPACK #-} !ByteArray {-# UNPACK #-} !ByteArray + +splitByteArray :: Int -> Int -> ByteArray -> (# ByteArray, ByteArray #) +splitByteArray offset n arr = + let f = runST $ do + let alen = sizeofByteArray arr + + mbrr <- newByteArray n + copyByteArray mbrr 0 arr offset n + brr <- unsafeFreezeByteArray mbrr + + let clen = alen - n + + mcrr <- newByteArray clen + copyByteArray mcrr 0 arr n clen + crr <- unsafeFreezeByteArray mcrr + + pure $ Wrap brr crr + + in case f of + Wrap brr crr -> (# brr, crr #) diff --git a/src/Data/Patricia/Word/Common.hs b/src/Data/Patricia/Word/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Common.hs @@ -0,0 +1,9 @@ +module Data.Patricia.Word.Common + ( Lookup (..) + ) where + + + +-- | Key together with the value. +data Lookup a = Lookup {-# UNPACK #-} !Word a + deriving Show diff --git a/src/Data/Patricia/Word/Conversion.hs b/src/Data/Patricia/Word/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Conversion.hs @@ -0,0 +1,30 @@ +module Data.Patricia.Word.Conversion where + +import Data.Patricia.Word.Lazy.Internal as Lazy +import Data.Patricia.Word.Strict.Internal as Strict + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Create a lazy 'Lazy.Patricia' tree from a strict one. +-- +-- The resulting tree does not share its data representation with the original. +toLazy :: StrictPatricia a -> LazyPatricia a +toLazy t = + case t of + Strict.Bin p l r -> Lazy.Bin p (toLazy l) (toLazy r) + Strict.Tip k a -> Lazy.Tip k a + Strict.Nil -> Lazy.Nil + + + +-- | \(\mathcal{O}(n)\). +-- Create a strict 'Strict.Patricia' tree from a lazy one. +-- +-- The resulting tree does not share its data representation with the original. +toStrict :: LazyPatricia a -> StrictPatricia a +toStrict t = + case t of + Lazy.Bin p l r -> Strict.Bin p (toStrict l) (toStrict r) + Lazy.Tip k a -> Strict.Tip k a + Lazy.Nil -> Strict.Nil diff --git a/src/Data/Patricia/Word/Debug.hs b/src/Data/Patricia/Word/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Debug.hs @@ -0,0 +1,24 @@ +module Data.Patricia.Word.Debug + ( Validity (..) + , Reason (..) + ) where + +import Radix.Word.Foundation + + + +-- | Whether the tree is well-formed. +data Validity = Valid + | Invalid Reason + deriving Show + +-- | Reason for why the tree is considered malformed. +data Reason = -- | Prefix is @0@. + ZeroPrefix + | -- | Prefix below diverges from the prefix above. + PrefixBelow Prefix Prefix + -- | Key diverges the prefix above. + | KeyBelow Prefix Key + -- | One of the branches is empty. + | MalformedBin Prefix + deriving Show diff --git a/src/Data/Patricia/Word/Lazy.hs b/src/Data/Patricia/Word/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Lazy.hs @@ -0,0 +1,246 @@ +{-| + @'LazyPatricia' a@ is a spine-lazy big-endian PATRICIA tree, a compressed + trie with a radix of 2, using 'Word's as keys. + + == Laziness + + Evaluating any particular entry in the tree to WHNF forces the evaluation + of the part of the spine leading up to that entry to normal form. + + == Performance + + Each function's time complexity is provided in the documentation. + + Laziness-amortized functions specify two time complexities: + time to construct the return value (denoted with a \(\texttt{+}\)) and time to + fully apply the function to the tree. + + \(n\) refers to the number of evaluated entries in the resulting tree. + Parts of the tree are denoted using subscripts: \(n_L\) refers to the left side, + \(n_R\) to the right side, \(n_I\) to a range (interval), and + \(n_M\) to entries collected with the use of a 'Monoid'. + + \(W\) is the size of 'Word' in bits, i.e. @'Data.Bits.finiteBitSize' (0 :: 'Word')@. + + == Implementation + + See the implementation section in "Data.Patricia.Word.Strict". + -} + +module Data.Patricia.Word.Lazy + ( LazyPatricia + , Patricia + + -- * Construct + , empty + , singleton + + -- ** Convert + , toStrict + + -- * Single-key + -- ** Lookup + , Data.Patricia.Word.Lazy.Internal.lookup + , Data.Patricia.Word.Lazy.Internal.find + , member + + -- ** Insert + , insert + , insertWith + + -- ** Map + , adjust + + -- ** Delete + , delete + + -- ** Update + , update + + , alter + + -- ** Take + , splitLookup + + -- * Directional + -- ** Lookup + , Lookup (..) + , lookupL + , lookupR + + -- ** Map + -- | === Left + , adjustL + , adjustLWithKey + + -- | === Right + , adjustR + , adjustRWithKey + + -- ** Delete + , deleteL + , deleteR + + -- ** Update + -- | === Left + , updateL + , updateLWithKey + + -- | === Right + , updateR + , updateRWithKey + + -- ** Take + -- | === Left + , takeL + , splitL + + -- | === Right + , takeR + , splitR + + -- * Range + , Range (Range) + + -- ** Map + , adjustRange + , adjustRangeWithKey + + -- ** Delete + , deleteRange + + -- ** Update + , updateRange + , updateRangeWithKey + + -- ** Take + , takeRange + + -- * Edges + + -- ** Lookup + -- | === Min + , lookupMin + , lookupMinWithKey + + -- | === Max + , lookupMax + , lookupMaxWithKey + + -- ** Map + -- | === Min + , adjustMin + , adjustMinWithKey + + -- | === Max + , adjustMax + , adjustMaxWithKey + + -- ** Delete + , deleteMin + , deleteMax + + -- ** Update + -- | === Min + , updateMin + , updateMinWithKey + + -- | === Max + , updateMax + , updateMaxWithKey + + -- ** View + -- | === Min + , ViewL (..) + , minView + + -- | === Max + , ViewR (..) + , maxView + + -- * Full tree + -- ** Size + , Data.Patricia.Word.Lazy.Internal.null + , size + + -- ** Map + , Data.Patricia.Word.Lazy.Internal.map + , mapWithKey + + -- ** Fold + -- | === Left-to-right + , Data.Patricia.Word.Lazy.Internal.foldl + , Data.Patricia.Word.Lazy.Internal.foldl' + , foldlWithKey + , foldlWithKey' + + -- | === Right-to-left + , Data.Patricia.Word.Lazy.Internal.foldr + , Data.Patricia.Word.Lazy.Internal.foldr' + , foldrWithKey + , foldrWithKey' + + -- | === Monoid + , Data.Patricia.Word.Lazy.Internal.foldMap + , foldMapWithKey + + -- ** Traverse + , Data.Patricia.Word.Lazy.Internal.traverse + , traverseWithKey + + -- ** Filter + -- | === One side + , Data.Patricia.Word.Lazy.Internal.filter + , filterWithKey + + , mapMaybe + , mapMaybeWithKey + + -- | === Both sides + , partition + , partitionWithKey + + , mapEither + , mapEitherWithKey + + -- ** Comparison + , PartialOrdering (..) + , Data.Patricia.Word.Lazy.Internal.compare + + -- ** Union + , union + , unionL + , unionWith + , unionWithKey + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , disjoint + , intersection + , intersectionL + , intersectionWith + , intersectionWithKey + + -- ** Merge + -- | See 'Data.Patricia.Word.Lazy.Unsafe.merge'. + ) where + +import Data.Patricia.Word.Common +import Data.Patricia.Word.Conversion +import Data.Patricia.Word.Lazy.Internal +import Radix.Common +import Radix.Word.Common + + + +-- | \(\mathcal{O}(1)\). Empty tree. +empty :: Patricia a +empty = Nil + +-- | \(\mathcal{O}(1)\). Tree with a single entry. +singleton :: Word -> a -> Patricia a +singleton = Tip diff --git a/src/Data/Patricia/Word/Lazy/Debug.hs b/src/Data/Patricia/Word/Lazy/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Lazy/Debug.hs @@ -0,0 +1,72 @@ +{-| + Safe functions for datatype introspection. + -} + +module Data.Patricia.Word.Lazy.Debug + ( -- * Show + showsTree + + -- * Validate + , Validity (..) + , Reason (..) + , validate + ) where + +import Data.Patricia.Word.Debug +import Data.Patricia.Word.Lazy.Internal +import Numeric.Long +import Radix.Word.Debug + + + +-- | \(\mathcal{O}(n)\). +-- Shows the internal structure of the tree. +showsTree :: (a -> ShowS) -> Patricia a -> ShowS +showsTree f = go 0 + where + go i t = + mappend (replicate i ' ') . + case t of + Bin p l r -> + showString "Bin " . showPrefix p . showChar '\n' + . go (i + 2) l . showChar '\n' + . go (i + 2) r + + Tip k a -> + showString "Tip " . showLongHex k . showString " => " . f a + + Nil -> showString "Nil" + + + +-- | \(\mathcal{O}(n)\). +-- Checks whether the tree is well-formed. +validate :: Patricia a -> Validity +validate t = + case t of + Bin p l r + | p == 0 -> Invalid ZeroPrefix + | otherwise -> + case go L p l of + Valid -> go R p r + err -> err + + Tip _ _ -> Valid + + Nil -> Valid + where + 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 -> + 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 + + Nil -> Invalid $ MalformedBin q diff --git a/src/Data/Patricia/Word/Lazy/Internal.hs b/src/Data/Patricia/Word/Lazy/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Lazy/Internal.hs @@ -0,0 +1,2583 @@ +{-# LANGUAGE BangPatterns + , DeriveLift + , GADTs + , RankNTypes + , ScopedTypeVariables + , UnboxedTuples #-} + +module Data.Patricia.Word.Lazy.Internal + ( LazyPatricia + , Patricia (..) + + , Data.Patricia.Word.Lazy.Internal.null + , size + + , Data.Patricia.Word.Lazy.Internal.map + , mapWithKey + + , Data.Patricia.Word.Lazy.Internal.foldl + , Data.Patricia.Word.Lazy.Internal.foldl' + , foldlWithKey + , foldlWithKey' + + , Data.Patricia.Word.Lazy.Internal.foldr + , Data.Patricia.Word.Lazy.Internal.foldr' + , foldrWithKey + , foldrWithKey' + + , Data.Patricia.Word.Lazy.Internal.foldMap + , foldMapWithKey + + , Data.Patricia.Word.Lazy.Internal.traverse + , traverseWithKey + + , union + , unionL + , unionWith + , unionWithKey + + , difference + , differenceWith + , differenceWithKey + + , Data.Patricia.Word.Lazy.Internal.compare + + , disjoint + , intersection + , intersectionL + , intersectionWith + , intersectionWithKey + + , merge + + , Data.Patricia.Word.Lazy.Internal.lookup + , Data.Patricia.Word.Lazy.Internal.find + , member + , takeOne + + , insert + , insertWith + + , adjust + + , delete + + , update + + , alter + + , lookupL + , lookupR + + , adjustL + , adjustLWithKey + + , adjustR + , adjustRWithKey + + , deleteL + , deleteR + + , updateL + , updateR + , updateLWithKey + , updateRWithKey + + , adjustRange + , unsafeAdjustRange + + , adjustRangeWithKey + , unsafeAdjustRangeWithKey + + , deleteRange + , unsafeDeleteRange + + , updateRange + , unsafeUpdateRange + + , updateRangeWithKey + , unsafeUpdateRangeWithKey + + , takeRange + , unsafeTakeRange + + , takeL + , takeR + + , splitL + , splitR + , splitLookup + + , Data.Patricia.Word.Lazy.Internal.filter + , filterWithKey + + , mapMaybe + , mapMaybeWithKey + + , partition + , partitionWithKey + + , mapEither + , mapEitherWithKey + + , lookupMin + , lookupMinWithKey + , lookupMax + , lookupMaxWithKey + + , unsafeLookupMin + , unsafeLookupMinWithKey + , unsafeLookupMax + , unsafeLookupMaxWithKey + + , deleteMin + , deleteMax + + , adjustMin + , adjustMinWithKey + , adjustMax + , adjustMaxWithKey + + , updateMin + , updateMinWithKey + , updateMax + , updateMaxWithKey + + , ViewL (..) + , minView + , unsafeMinView + + , ViewR (..) + , maxView + , unsafeMaxView + ) where + +import Data.Patricia.Word.Common +import Radix.Common +import Radix.Exception +import Radix.Word.Common +import Radix.Word.Foundation + +import Control.Applicative +import Control.DeepSeq +import Control.Exception (throw) +import Data.Bits +import Data.Foldable +import Data.Functor.Classes +import Language.Haskell.TH.Syntax (Lift) +import Text.Read +import Text.Show + + + +-- | Convenience synonym. +type LazyPatricia = Patricia + +-- | Spine-lazy PATRICIA tree. +data Patricia a = Bin + {-# UNPACK #-} !Prefix + (Patricia a) -- ^ Masked bit is @0@. + (Patricia a) -- ^ Masked bit is @1@. + + | Tip + {-# UNPACK #-} !Key + a + + | Nil -- ^ Invariant: only allowed as the root of the tree. + deriving Lift + +instance Show a => Show (Patricia a) where + showsPrec = liftShowsPrec showsPrec showList + +instance Show1 Patricia where + liftShowsPrec showsPrec_ showList_ _ t = + showListWith (liftShowsPrec showsPrec_ showList_ 0) $ + foldrWithKey (\k a -> (:) (k, a)) [] t + +instance Read a => Read (Patricia a) where + readPrec = liftReadPrec readPrec readListPrec + +instance Read1 Patricia where + liftReadPrec readPrec_ readList_ = + fmap (Data.Foldable.foldl' (\z (k, a) -> insert k a z) Nil) + (liftReadListPrec readPrec_ readList_) + + +instance Eq a => Eq (Patricia a) where + (==) = liftEq (==) + +instance Eq1 Patricia where + liftEq eq = go + where + go l r = + case l of + Bin p xl xr -> + case r of + Bin q yl yr -> p == q && go xl yl && go xr yr + _ -> False + + Tip kA a -> + case r of + Tip kB b -> kA == kB && eq a b + _ -> False + + Nil -> + case r of + Nil -> True + _ -> False + + +instance Functor Patricia where + fmap = Data.Patricia.Word.Lazy.Internal.map + +instance Foldable Patricia where + foldl = Data.Patricia.Word.Lazy.Internal.foldl + foldr = Data.Patricia.Word.Lazy.Internal.foldr + foldMap = Data.Patricia.Word.Lazy.Internal.foldMap + + foldl' = Data.Patricia.Word.Lazy.Internal.foldl' + foldr' = Data.Patricia.Word.Lazy.Internal.foldr' + + null = Data.Patricia.Word.Lazy.Internal.null + length = fromIntegral . size + +instance Traversable Patricia where + traverse = Data.Patricia.Word.Lazy.Internal.traverse + + +instance NFData a => NFData (Patricia a) where + rnf = liftRnf rnf + +instance NFData1 Patricia where + liftRnf nf = go + where + go t = + case t of + Bin _ l r -> go l `seq` go r + Tip _ a -> nf a + Nil -> () + + + +{-# INLINE join #-} +-- | Knowing that the prefices of two non-'Nil' trees disagree, construct a 'Bin'. +join :: Prefix -> Patricia a -> Prefix -> Patricia a -> Patricia a +join p0 t0 p1 t1 = + let m = branchingBit p0 p1 + + p = mask p0 m .|. m + + in if zeroBit p0 m + then Bin p t0 t1 + else Bin p t1 t0 + +{-# INLINE safeJoin #-} +-- | Knowing that the prefices of two trees disagree, construct a 'Bin'. +safeJoin :: Prefix -> Patricia a -> Prefix -> Patricia a -> Patricia a +safeJoin _ Nil _ t1 = t1 +safeJoin _ t0 _ Nil = t0 +safeJoin p0 t0 p1 t1 = join p0 t0 p1 t1 + +{-# INLINE rebin #-} +-- | Reconstruct a 'Bin' knowing that either of the sides may now be a 'Nil'. +rebin :: Prefix -> Patricia a -> Patricia a -> Patricia a +rebin p l r = + case l of + Nil -> r + _ -> + case r of + Nil -> l + _ -> Bin p l r + +{-# INLINE rebinL #-} +-- | Reconstruct a 'Bin' knowing that the left side may now be a 'Nil'. +rebinL :: Prefix -> Patricia a -> Patricia a -> Patricia a +rebinL p l r = + case l of + Nil -> r + _ -> Bin p l r + + +{-# INLINE rebinR #-} +-- | Reconstruct a 'Bin' knowing that the right side may now be a 'Nil'. +rebinR :: Prefix -> Patricia a -> Patricia a -> Patricia a +rebinR p l r = + case r of + Nil -> l + _ -> Bin p l r + + +{-# INLINE retip #-} +-- | Reconstruct a 'Tip' knowing that the value may not be there anymore. +retip :: Key -> Maybe a -> Patricia a +retip w (Just a) = Tip w a +retip _ Nothing = Nil + + + +-- | \(\mathcal{O}(1)\). +-- Check if the tree is empty. +null :: Patricia a -> Bool +null Nil = True +null _ = False + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of elements stored in the tree. +-- The returned number is guaranteed to be non-negative. +size :: Patricia a -> Int +size t = + case t of + Bin _ l r -> let !m = size l + !n = size r + in m + n + + Tip _ _ -> 1 + + Nil -> 0 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree. +map :: (a -> b) -> Patricia a -> Patricia b +map f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) (go r) + Tip k a -> Tip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree. +mapWithKey :: (Word -> a -> b) -> Patricia a -> Patricia b +mapWithKey f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) (go r) + Tip k a -> Tip k (f k a) + Nil -> Nil + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldl :: (b -> a -> b) -> b -> Patricia a -> b +foldl f = go + where + go z t = + case t of + Bin _ l r -> go (go z l) r + Tip _ a -> f z a + Nil -> z + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldlWithKey :: (b -> Word -> a -> b) -> b -> Patricia a -> b +foldlWithKey f = go + where + go z t = + case t of + Bin _ l r -> go (go z l) r + Tip k a -> f z k a + Nil -> z + + + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldl' :: (b -> a -> b) -> b -> Patricia a -> b +foldl' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z l + in go z' r + Tip _ a -> f z a + Nil -> z + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldlWithKey' :: (b -> Word -> a -> b) -> b -> Patricia a -> b +foldlWithKey' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z l + in go z' r + Tip k a -> f z k a + Nil -> z + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldr :: (a -> b -> b) -> b -> Patricia a -> b +foldr f = go + where + go z t = + case t of + Bin _ l r -> go (go z r) l + Tip _ a -> f a z + Nil -> z + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldrWithKey :: (Word -> a -> b -> b) -> b -> Patricia a -> b +foldrWithKey f = go + where + go z t = + case t of + Bin _ l r -> go (go z r) l + Tip k a -> f k a z + Nil -> z + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldr' :: (a -> b -> b) -> b -> Patricia a -> b +foldr' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z r + in go z' l + Tip _ a -> f a z + Nil -> z + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldrWithKey' :: (Word -> a -> b -> b) -> b -> Patricia a -> b +foldrWithKey' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z r + in go z' l + Tip k a -> f k a z + Nil -> z + + + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMap :: Monoid m => (a -> m) -> Patricia a -> m +foldMap f = go + where + go t = + case t of + Bin _ l r -> go l <> go r + Tip _ a -> f a + Nil -> mempty + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMapWithKey :: Monoid m => (Word -> a -> m) -> Patricia a -> m +foldMapWithKey f = go + where + go t = + case t of + Bin _ l r -> go l <> go r + Tip k a -> f k a + Nil -> mempty + + + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverse :: Applicative f => (a -> f b) -> Patricia a -> f (Patricia b) +traverse f = go + where + go t = + case t of + Bin p l r -> liftA2 (Bin p) (go l) (go r) + Tip k a -> Tip k <$> f a + Nil -> pure Nil + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverseWithKey :: Applicative f => (Word -> a -> f b) -> Patricia a -> f (Patricia b) +traverseWithKey f = go + where + go t = + case t of + Bin p l r -> liftA2 (Bin p) (go l) (go r) + Tip k a -> Tip k <$> f k a + Nil -> pure Nil + + + +type UBin a = (# Prefix, Patricia a, Patricia a #) + +type UTip a = (# Word, a #) + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Unbiased union of two trees. +union :: Patricia a -> Patricia a -> Patricia a +union = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip kA _ -> tipAny kA tA tB + + Nil -> tB + + tipAny kA tA tB = + case tB of + Bin pB lB rB -> tipBin kA tA (# pB, lB, rB #) tB + + Tip kB _ + | kA == kB -> tA + | otherwise -> join kA tA kB tB + + Nil -> tA + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip kB _ -> tipBin kB tB uA tA + + Nil -> tA + + tipBin kA tA (# pB, lB, rB #) tB + | beyond pB kA = join kA tA pB tB + | kA < pB = Bin pB (tipAny kA tA lB) rB + | otherwise = Bin pB lB (tipAny kA tA rB) + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> Bin pA lA (binAny uB tB rA) + | pA >= lower pB -> Bin pB (binAny uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny uA tA rB) + | pB >= lower pA -> Bin pA (binAny uB tB lA) rA + | otherwise -> no + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Left-biased union of two trees. +unionL :: Patricia a -> Patricia a -> Patricia a +unionL = + union_ $ \s k a b -> + let !(# c #) = case s of + L -> (# a #) + R -> (# b #) + in Tip k c + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Union of two trees with a combining function. +unionWith + :: (a -> a -> a) + -> Patricia a + -> Patricia a + -> Patricia a +unionWith f = + union_ $ \s k a b -> + let !(# c #) = case s of + L -> (# f a b #) + R -> (# f b a #) + in Tip k c + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Union of two trees with a combining function. +unionWithKey + :: (Word -> a -> a -> a) + -> Patricia a + -> Patricia a + -> Patricia a +unionWithKey f = + union_ $ \s k a b -> + let !(# c #) = case s of + L -> (# f k a b #) + R -> (# f k b a #) + in Tip k c + + + +{-# INLINE union_ #-} +union_ + :: (forall x y. S x y a a -> Key -> x -> y -> Patricia a) + -> Patricia a + -> Patricia a + -> Patricia a +union_ f = anyAny L + where + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> tB + + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB + + Tip kB b + | kA == kB -> f s kA a b + | otherwise -> join kA tA kB tB + + Nil -> tA + + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> + let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA tA + + Nil -> tA + + tipBin s uA@(# kA, _ #) tA (# pB, lB, rB #) tB + | beyond pB kA = join kA tA pB tB + | kA < pB = Bin pB (tipAny s uA tA lB) rB + | otherwise = Bin pB lB (tipAny s uA tA rB) + + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in Bin pA lA (binAny s' uB tB rA) + | pA >= lower pB -> Bin pB (binAny s uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny s uA tA rB) + | pB >= lower pA -> let !(# s' #) = other s + in Bin pA (binAny s' uB tB lA) rA + | otherwise -> no + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Difference of two trees. +difference :: Patricia a -> Patricia b -> Patricia a +difference = + difference_ $ \_ _ _ _ -> + Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Difference of two trees with a combining function. +differenceWith + :: (a -> b -> Maybe a) + -> Patricia a + -> Patricia b + -> Patricia a +differenceWith f = + difference_ $ \s k a b -> + retip k $ case s of + L -> f a b + R -> f b a + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Difference of two trees with a combining function. +differenceWithKey + :: (Word -> a -> b -> Maybe a) + -> Patricia a + -> Patricia b + -> Patricia a +differenceWithKey f = + difference_ $ \s k a b -> + retip k $ case s of + L -> f k a b + R -> f k b a + + + +{-# INLINE difference_ #-} +difference_ + :: (forall x y. S x y a b -> Key -> x -> y -> Patricia a) + -> Patricia a + -> Patricia b + -> Patricia a +difference_ (f :: forall n o. S n o x y -> Key -> n -> o -> Patricia x) = anyAny L + where + anyAny + :: forall a b. S a b x y -> Patricia a -> Patricia b -> Patricia x + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> case s of + L -> tA + R -> tB + + tipAny + :: forall a b. S a b x y -> UTip a -> Patricia a -> Patricia b -> Patricia x + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB + + Tip kB b + | kA == kB -> f s kA a b + | otherwise -> case s of + L -> tA + R -> tB + + Nil -> case s of + L -> tA + R -> tB + + binAny + :: forall a b. S a b x y -> UBin a -> Patricia a -> Patricia b -> Patricia x + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA tA + + Nil -> case s of + L -> tA + R -> tB + + tipBin + :: forall a b. S a b x y -> UTip a -> Patricia a -> UBin b -> Patricia b -> Patricia x + tipBin s uA@(# kA, _ #) tA (# pB, lB, rB #) tB + | beyond pB kA = case s of + L -> tA + R -> tB + + | kA < pB = case s of + L -> tipAny s uA tA lB + R -> rebinL pB (tipAny s uA tA lB) rB + + | otherwise = case s of + L -> tipAny s uA tA rB + R -> rebinR pB lB (tipAny s uA tA rB) + + binBin + :: forall a b. S a b x y -> UBin a -> Patricia a -> UBin b -> Patricia b -> Patricia x + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = case s of + L -> tA + R -> tB + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> case s of + L -> rebinR pA lA (binAny R uB tB rA) + R -> binAny L uB tB rA + + | pA >= lower pB -> case s of + L -> binAny s uA tA lB + R -> rebinL pB (binAny s uA tA lB) rB + + | otherwise -> no + + GT | pA <= upper pB -> case s of + L -> binAny s uA tA rB + R -> rebinR pB lB (binAny s uA tA rB) + + | pB >= lower pA -> case s of + L -> rebinL pA (binAny R uB tB lA) rA + R -> binAny L uB tB lA + + | otherwise -> no + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Compare two trees with respect to set inclusion, +-- using the given equality function for intersecting keys. +-- If any intersecting keys hold unequal values, the trees are 'Incomparable'. +compare :: (a -> b -> Bool) -> Patricia a -> Patricia b -> PartialOrdering +compare (f :: x -> y -> Bool) = anyAny L + where + anyAny + :: forall a b. S a b x y -> Patricia a -> Patricia b -> PartialOrdering + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> case tB of + Nil -> Equal + _ -> Subset + + tipAny + :: forall a b. S a b x y -> UTip a -> Patricia a -> Patricia b -> PartialOrdering + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip kB b + | kA == kB -> let eq = case s of + L -> f a b + R -> f b a + in if eq + then Equal + else Incomparable + + | otherwise -> Incomparable + + Nil -> Superset + + binAny + :: forall a b. S a b x y -> UBin a -> Patricia a -> Patricia b -> PartialOrdering + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA + + Nil -> Superset + + tipBin + :: forall a b. S a b x y -> UTip a -> Patricia a -> UBin b -> PartialOrdering + tipBin s uA@(# kA, _ #) tA (# pB, lB, rB #) = + if beyond pB kA + then Incomparable + else limit s . tipAny s uA tA $ if kA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y -> UBin a -> Patricia a -> UBin b -> Patricia b -> PartialOrdering + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> order (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in limit s' $ binAny s' uB tB rA + + | pA >= lower pB -> limit s $ binAny s uA tA lB + + | otherwise -> Incomparable + + GT | pA <= upper pB -> limit s $ binAny s uA tA rB + + | pB >= lower pA -> let !(# s' #) = other s + + in limit s' $ binAny s' uB tB lA + + | otherwise -> Incomparable + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Determine whether two trees' key sets are disjoint. +disjoint :: Patricia a -> Patricia b -> Bool +disjoint = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip kA _ -> tipAny kA tA tB + + Nil -> True + + tipAny kA tA tB = + case tB of + Bin pB lB rB -> tipBin kA tA (# pB, lB, rB #) + + Tip kB _ -> kA /= kB + + Nil -> True + + binAny :: forall a b. UBin a -> Patricia a -> Patricia b -> Bool + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip kB _ -> tipBin kB tB uA + + Nil -> True + + tipBin kA tA (# pB, lB, rB #) + | beyond pB kA = True + | otherwise = tipAny kA tA $ if kA < pB + then lB + else rB + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> anyAny lA lB && anyAny rA rB + + LT | pB <= upper pA -> binAny uB tB rA + | pA >= lower pB -> binAny uA tA lB + | otherwise -> True + + GT | pA <= upper pB -> binAny uA tA rB + | pB >= lower pA -> binAny uB tB lA + | otherwise -> True + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Unbiased intersection of two trees. +intersection :: Patricia a -> Patricia a -> Patricia a +intersection = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip kA _ -> tipAny kA tA tB + + Nil -> Nil + + tipAny kA tA tB = + case tB of + Bin pB lB rB -> tipBin kA tA (# pB, lB, rB #) + + Tip kB _ + | kA == kB -> tA + | otherwise -> Nil + + Nil -> Nil + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip kB _ -> tipBin kB tB uA + + Nil -> Nil + + tipBin kA tA (# pB, lB, rB #) + | beyond pB kA = Nil + | otherwise = tipAny kA tA $ if kA < pB + then lB + else rB + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> binAny uB tB rA + | pA >= lower pB -> binAny uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny uA tA rB + | pB >= lower pA -> binAny uB tB lA + | otherwise -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Left-biased intersection of two trees. +intersectionL :: Patricia a -> Patricia b -> Patricia a +intersectionL = + intersection_ $ \s k a b -> + let !(# c #) = case s of + L -> (# a #) + R -> (# b #) + in Tip k c + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Intersection of two trees with a combining function. +intersectionWith + :: (a -> b -> c) + -> Patricia a + -> Patricia b + -> Patricia c +intersectionWith f = + intersection_ $ \s k a b -> + let !(# c #) = case s of + L -> (# f a b #) + R -> (# f b a #) + in Tip k c + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- Intersection of two trees with a combining function. +intersectionWithKey + :: (Word -> a -> b -> c) + -> Patricia a + -> Patricia b + -> Patricia c +intersectionWithKey f = + intersection_ $ \s k a b -> + let !(# c #) = case s of + L -> (# f k a b #) + R -> (# f k b a #) + in Tip k c + + + +{-# INLINE intersection_ #-} +intersection_ + :: (forall x y. S x y a b -> Key -> x -> y -> Patricia c) + -> Patricia a + -> Patricia b + -> Patricia c +intersection_ (f :: forall n o. S n o x y -> Word -> n -> o -> Patricia c) = + anyAny L + where + anyAny + :: forall a b. S a b x y -> Patricia a -> Patricia b -> Patricia c + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> Nil + + tipAny + :: forall a b. S a b x y -> UTip a -> Patricia a -> Patricia b -> Patricia c + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip kB b + | kA == kB -> f s kA a b + | otherwise -> Nil + + Nil -> Nil + + binAny + :: forall a b. S a b x y -> UBin a -> Patricia a -> Patricia b -> Patricia c + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA + + Nil -> Nil + + tipBin + :: forall a b. S a b x y -> UTip a -> Patricia a -> UBin b -> Patricia c + tipBin s uA@(# kA, _ #) tA (# pB, lB, rB #) + | beyond pB kA = Nil + | otherwise = tipAny s uA tA $ if kA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y -> UBin a -> Patricia a -> UBin b -> Patricia b -> Patricia c + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in binAny s' uB tB rA + | pA >= lower pB -> binAny s uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny s uA tA rB + | pB >= lower pA -> let !(# s' #) = other s + in binAny s' uB tB lA + | otherwise -> Nil + + + +{-# INLINE merge #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A + n_B)\). +-- General merge of two trees. +-- +-- Collision and single value functions __must__ return either +-- 'Tip' with the respective key, or 'Nil'. +-- +-- Subtree argument functions may return any tree, however the shape of said tree +-- __must__ be compatible with the prefix passed to the function. +-- +-- This functions inlines when all argument functions are provided. +merge + :: (Key -> a -> b -> Patricia c) -- ^ Collision + -> (Key -> a -> Patricia c) -- ^ Single left value + -> (Prefix -> Patricia a -> Patricia a -> Patricia c) -- ^ Left subtree + -> (Key -> b -> Patricia c) -- ^ Single right value + -> (Prefix -> Patricia b -> Patricia b -> Patricia c) -- ^ Right subtree + -> Patricia a + -> Patricia b + -> Patricia c +merge (f :: Key -> x -> y -> Patricia c) oneX treeX oneY treeY = anyAny L + where + {-# INLINE side #-} + side one tree t = + case t of + Bin p l r -> tree p l r + Tip k a -> one k a + Nil -> Nil + + sideX = side oneX treeX + + sideY = side oneY treeY + + sideA :: forall a b. S a b x y -> Patricia a -> Patricia c + sideA s tA = case s of + L -> sideX tA + R -> sideY tA + + sideB :: forall a b. S a b x y -> Patricia b -> Patricia c + sideB s tB = case s of + L -> sideY tB + R -> sideX tB + + anyAny + :: forall a b. S a b x y -> Patricia a -> Patricia b -> Patricia c + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> sideB s tB + + tipAny + :: forall a b. S a b x y -> UTip a -> Patricia a -> Patricia b -> Patricia c + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip kB b + | kA == kB -> case s of + L -> f kA a b + R -> f kA b a + + | otherwise -> case s of + L -> safeJoin kA (oneX kA a) kB (sideY tB) + R -> safeJoin kA (oneY kA a) kB (sideX tB) + + Nil -> sideA s tA + + binAny + :: forall a b. S a b x y -> UBin a -> Patricia a -> Patricia b -> Patricia c + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA + + Nil -> sideA s tA + + tipBin + :: forall a b. S a b x y -> UTip a -> Patricia a -> UBin b -> Patricia c + tipBin s uA@(# kA, a #) tA (# pB, lB, rB #) + | beyond pB kA = case s of + L -> safeJoin kA (oneX kA a) pB (treeY pB lB rB) + R -> safeJoin kA (oneY kA a) pB (treeX pB lB rB) + + | kA < pB = rebin pB (tipAny s uA tA lB) (sideB s rB) + + | otherwise = rebin pB (sideB s lB) (tipAny s uA tA rB) + + binBin + :: forall a b. S a b x y -> UBin a -> Patricia a -> UBin b -> Patricia b -> Patricia c + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = case s of + L -> safeJoin pA (treeX pA lA rA) pB (treeY pB lB rB) + R -> safeJoin pA (treeY pA lA rA) pB (treeX pB lB rB) + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + + in rebin pA (sideA s lA) (binAny s' uB tB rA) + + | pA >= lower pB -> rebin pB (binAny s uA tA lB) (sideB s rB) + + | otherwise -> no + + GT | pA <= upper pB -> rebin pB (sideB s lB) (binAny s uA tA rB) + + | pB >= lower pA -> let !(# s' #) = other s + + in rebin pA (binAny s' uB tB lA) (sideA s rA) + + | otherwise -> no + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the value at a key in the tree. +lookup :: Word -> Patricia a -> Maybe a +lookup !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> Nothing + | w < p -> go l + | otherwise -> go r + + Tip k a + | k == w -> Just a + | otherwise -> Nothing + + Nil -> Nothing + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the value at a key in the tree, falling back to the given default value +-- if it does not exist. +find :: a -> Word -> Patricia a -> a +find d !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> d + | w < p -> go l + | otherwise -> go r + + Tip k a + | k == w -> a + | otherwise -> d + + Nil -> d + +-- | \(\mathcal{O}(\min(n,W))\). +-- Check whether the value exists at a key in the tree. +member :: Word -> Patricia a -> Bool +member !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> False + | w < p -> go l + | otherwise -> go r + + Tip k _ -> k == w + + Nil -> False + +-- 'lookup' that doesn't allocate a 'Maybe'. +takeOne :: Word -> Patricia a -> Patricia a +takeOne !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> Nil + | w < p -> go l + | otherwise -> go r + + Tip k _ + | k == w -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, it is replaced. +insert :: Word -> a -> Patricia a -> Patricia a +insert !w a = go + where + go t = + case t of + Bin p l r + | beyond p w -> join w (Tip w a) p t + | w < p -> Bin p (go l) r + | otherwise -> Bin p l (go r) + + Tip k _ + | k == w -> Tip k a + | otherwise -> join w (Tip w a) k t + + Nil -> Tip w a + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, the function is used instead. +insertWith :: (a -> a) -> Word -> a -> Patricia a -> Patricia a +insertWith f !w b = go + where + go t = + case t of + Bin p l r + | beyond p w -> join w (Tip w b) p t + | w < p -> Bin p (go l) r + | otherwise -> Bin p l (go r) + + Tip k a + | k == w -> Tip k (f a) + | otherwise -> join w (Tip w b) k t + + Nil -> Tip w b + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Apply a function to a value in the tree at the given key. +adjust :: (a -> a) -> Word -> Patricia a -> Patricia a +adjust f !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> Bin p (go l) r + | otherwise -> Bin p l (go r) + + Tip k a + | k == w -> Tip k (f a) + | otherwise -> t + + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Delete a value in the tree at the given key. +delete :: Word -> Patricia a -> Patricia a +delete !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go l) r + | otherwise -> rebinR p l (go r) + + Tip k _ + | k == w -> Nil + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Update or delete a value in the tree at the given key. +update :: (a -> Maybe a) -> Word -> Patricia a -> Patricia a +update f !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go l) r + | otherwise -> rebinR p l (go r) + + Tip k a + | k == w -> retip k (f a) + | otherwise -> t + + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Insert, update or delete a value in the tree at the given key. +alter :: (Maybe a -> Maybe a) -> Word -> Patricia a -> Patricia a +alter f !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> case f Nothing of + Just b -> join p t w (Tip w b) + Nothing -> t + + | w < p -> rebinL p (go l) r + | otherwise -> rebinR p l (go r) + + Tip k a + | k == w -> case f (Just a) of + Just b -> Tip k b + Nothing -> Nil + + | otherwise -> case f Nothing of + Just b -> join k t w (Tip w b) + Nothing -> t + + Nil -> case f Nothing of + Just b -> Tip w b + Nothing -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at a largest key smaller than or equal to the given key. +lookupL :: Word -> Patricia a -> Maybe (Lookup a) +lookupL !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go l + else Nothing + + else Just $! if w <= upper p + then case go r of + Just x -> x + Nothing -> unsafeLookupMaxWithKey l + + else unsafeLookupMaxWithKey r + + Tip k a + | k <= w -> Just $! Lookup k a + | otherwise -> Nothing + + Nil -> Nothing + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at a smallest key greater than or equal to the given key. +lookupR :: Word -> Patricia a -> Maybe (Lookup a) +lookupR !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then Just $! if w >= lower p + then case go l of + Just x -> x + Nothing -> unsafeLookupMinWithKey r + + else unsafeLookupMinWithKey l + + else if w <= upper p + then go r + else Nothing + + Tip k a + | k >= w -> Just $! Lookup k a + | otherwise -> Nothing + + Nil -> Nothing + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- or equal to the given one. +adjustL :: (a -> a) -> Word -> Patricia a -> Patricia a +adjustL f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go l) r + else t + + else Bin p (Data.Patricia.Word.Lazy.Internal.map f l) $ + if w <= upper p + then go r + else Data.Patricia.Word.Lazy.Internal.map f r + + Tip k a + | k <= w -> Tip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- or equal to the given one. +adjustLWithKey :: (Word -> a -> a) -> Word -> Patricia a -> Patricia a +adjustLWithKey f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go l) r + else t + + else Bin p (mapWithKey f l) $ + if w <= upper p + then go r + else mapWithKey f r + + Tip k a + | k <= w -> Tip k (f k a) + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Delete values for which keys are smaller than or equal to the given one. +deleteL :: Word -> Patricia a -> Patricia a +deleteL !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go l) r + else t + + else if w <= upper p + then go r + else Nil + + Tip k _ + | k <= w -> Nil + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_L)\). +-- Update every value for which the key is smaller than or equal to the given one. +updateL :: (a -> Maybe a) -> Word -> Patricia a -> Patricia a +updateL f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go l) r + else t + + else rebin p (mapMaybe f l) $ + if w <= upper p + then go r + else mapMaybe f r + + Tip k a + | k <= w -> retip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_L)\). +-- Update every value for which the key is smaller than or equal to the given one. +updateLWithKey :: (Word -> a -> Maybe a) -> Word -> Patricia a -> Patricia a +updateLWithKey f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go l) r + else t + + else rebin p (mapMaybeWithKey f l) $ + if w <= upper p + then go r + else mapMaybeWithKey f r + + Tip k a + | k <= w -> retip k (f k a) + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Take values for which keys are smaller than or equal to the given one. +takeL :: Word -> Patricia a -> Patricia a +takeL !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go l + else Nil + + else if w <= upper p + then rebinR p l (go r) + else t + + Tip k _ + | k <= w -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- or equal to the given one. +adjustR :: (a -> a) -> Word -> Patricia a -> Patricia a +adjustR f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else Data.Patricia.Word.Lazy.Internal.map f l + + in Bin p l' (Data.Patricia.Word.Lazy.Internal.map f r) + + else if w <= upper p + then Bin p l (go r) + else t + + Tip k a + | k >= w -> Tip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- or equal to the given one. +adjustRWithKey :: (Word -> a -> a) -> Word -> Patricia a -> Patricia a +adjustRWithKey f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else mapWithKey f l + + in Bin p l' (mapWithKey f r) + + else if w <= upper p + then Bin p l (go r) + else t + + Tip k a + | k >= w -> Tip k (f k a) + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Delete values for which keys are greater than or equal to the given one. +deleteR :: Word -> Patricia a -> Patricia a +deleteR !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go l + else Nil + + else if w <= upper p + then rebinR p l (go r) + else t + + Tip k _ + | k >= w -> Nil + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_R)\). +-- Update every value for which the key is greater than or equal to the given one. +updateR :: (a -> Maybe a) -> Word -> Patricia a -> Patricia a +updateR f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else mapMaybe f l + + in rebin p l' (mapMaybe f r) + + else if w <= upper p + then rebinR p l (go r) + else t + + Tip k a + | k >= w -> retip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_R)\). +-- Update every value for which the key is greater than or equal to the given one. +updateRWithKey :: (Word -> a -> Maybe a) -> Word -> Patricia a -> Patricia a +updateRWithKey f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else mapMaybeWithKey f l + + in rebin p l' (mapMaybeWithKey f r) + + else if w <= upper p + then rebinR p l (go r) + else t + + Tip k a + | k >= w -> retip k (f k a) + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Take values for which keys are greater than or equal to the given one. +takeR :: Word -> Patricia a -> Patricia a +takeR !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go l) r + else t + + else if w <= upper p + then go r + else Nil + + Tip k _ + | k >= w -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +adjustRange :: (a -> a) -> Range -> Patricia a -> Patricia a +adjustRange f (UnsafeRange kL kR) + | kL == kR = adjust f kL + | otherwise = unsafeAdjustRange f kL kR + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeAdjustRange + :: (a -> a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeAdjustRange f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> Bin p (adjustR f wL l) (adjustL f wR r) + + LT | pM <= upper p -> Bin p l (go r) + | p >= lower pM -> if wL < p + then Bin p + (adjustR f wL l) + (Data.Patricia.Word.Lazy.Internal.map f r) + + else Bin p l (adjustR f wL r) + + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then Bin p + (Data.Patricia.Word.Lazy.Internal.map f l) + (adjustL f wR r) + + else Bin p (adjustL f wR l) r + + | pM >= lower p -> Bin p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> Tip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +adjustRangeWithKey :: (Word -> a -> a) -> Range -> Patricia a -> Patricia a +adjustRangeWithKey f (UnsafeRange kL kR) + | kL == kR = adjust (f kL) kL + | otherwise = unsafeAdjustRangeWithKey f kL kR + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeAdjustRangeWithKey + :: (Word -> a -> a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeAdjustRangeWithKey f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> Bin p (adjustRWithKey f wL l) (adjustLWithKey f wR r) + + LT | pM <= upper p -> Bin p l (go r) + | p >= lower pM -> if wL < p + then Bin p (adjustRWithKey f wL l) (mapWithKey f r) + else Bin p l (adjustRWithKey f wL r) + + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then Bin p (mapWithKey f l) (adjustLWithKey f wR r) + else Bin p (adjustLWithKey f wR l) r + + | pM >= lower p -> Bin p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> Tip k (f k a) + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Delete values for which keys are in the given range. +deleteRange :: Range -> Patricia a -> Patricia a +deleteRange (UnsafeRange kL kR) + | kL == kR = delete kL + | otherwise = unsafeDeleteRange kL kR + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Delete values for which keys are in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeDeleteRange + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeDeleteRange !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> rebin p (deleteR wL l) (deleteL wR r) + + LT | pM <= upper p -> rebinR p l (go r) + | p >= lower pM -> if wL < p + then deleteR wL l + else rebinR p l (deleteR wL r) + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then deleteL wR r + else rebinL p (deleteL wR l) r + + | pM >= lower p -> rebinL p (go l) r + | otherwise -> t + + Tip k _ + | k >= wL && k <= wR -> Nil + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_I)\). +-- Update every value for which the key is in the given range. +updateRange :: (a -> Maybe a) -> Range -> Patricia a -> Patricia a +updateRange f (UnsafeRange kL kR) + | kL == kR = update f kL + | otherwise = unsafeUpdateRange f kL kR + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_I)\). +-- Update every value for which the key is in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeUpdateRange + :: (a -> Maybe a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeUpdateRange f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> rebin p (updateR f wL l) (updateL f wR r) + + LT | pM <= upper p -> rebinR p l (go r) + | p >= lower pM -> if wL < p + then rebinL p (updateR f wL l) (mapMaybe f r) + else rebinR p l (updateR f wL r) + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then rebinR p (mapMaybe f l) (updateL f wR r) + else rebinL p (updateL f wR l) r + + | pM >= lower p -> rebinL p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> retip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_I)\). +-- Update every value for which the key is in the given range. +updateRangeWithKey :: (Word -> a -> Maybe a) -> Range -> Patricia a -> Patricia a +updateRangeWithKey f (UnsafeRange kL kR) + | kL == kR = update (f kL) kL + | otherwise = unsafeUpdateRangeWithKey f kL kR + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W) + n_I)\). +-- Update every value for which the key is in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeUpdateRangeWithKey + :: (Word -> a -> Maybe a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeUpdateRangeWithKey f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> rebin p (updateRWithKey f wL l) (updateLWithKey f wR r) + + LT | pM <= upper p -> rebinR p l (go r) + | p >= lower pM -> if wL < p + then rebinL p (updateRWithKey f wL l) + (mapMaybeWithKey f r) + + else rebinR p l (updateRWithKey f wL r) + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then rebinR p (mapMaybeWithKey f l) + (updateLWithKey f wR r) + + else rebinL p (updateLWithKey f wR l) r + + | pM >= lower p -> rebinL p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> retip k (f k a) + | otherwise -> t + + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Take values for which keys are in the given range. +takeRange :: Range -> Patricia a -> Patricia a +takeRange (UnsafeRange kL kR) + | kL == kR = takeOne kL + | otherwise = unsafeTakeRange kL kR + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Take values for which keys are in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeTakeRange + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeTakeRange !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> rebin p (takeR wL l) (takeL wR r) + + LT | pM <= upper p -> go r + | p >= lower pM -> if wL < p + then rebinL p (takeR wL l) r + else takeR wL r + + | otherwise -> Nil + + GT | p <= upper pM -> if wR >= p + then rebinR p l (takeL wR r) + else takeL wR l + + | pM >= lower p -> go l + | otherwise -> Nil + + Tip k _ + | k >= wL && k <= wR -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Split the tree into two, such that +-- values with keys smaller than or equal to the given one are on the left, +-- and values with keys greater than the given one are on the right. +splitL :: Word -> Patricia a -> (Patricia a, Patricia a) +splitL !w = \t -> + case go t of + (# l, r #) -> (l, r) + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let !(# ll, lr #) = go l + in (# ll, rebinL p lr r #) + + else (# Nil, t #) + + else if w <= upper p + then let !(# rl, rr #) = go r + in (# rebinR p l rl, rr #) + + else (# t, Nil #) + + Tip k _ + | w >= k -> (# t, Nil #) + | otherwise -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Split the tree into two, such that +-- values with keys smaller than the given one are on the left, +-- and values with keys greater than or equal to the given one are on the right. +splitR :: Word -> Patricia a -> (Patricia a, Patricia a) +splitR !w = \t -> + case go t of + (# l, r #) -> (l, r) + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let (# ll, lr #) = go l + in (# ll, rebinL p lr r #) + + else (# Nil, t #) + + else if w <= upper p + then let (# rl, rr #) = go r + in (# rebinR p l rl, rr #) + + else (# t, Nil #) + + Tip k _ + | w > k -> (# t, Nil #) + | otherwise -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Split the tree into two, such that +-- values with keys smaller than the given one are on the left, +-- values with keys greater than the given one are on the right, +-- and the value at the given key is returned separately. +splitLookup :: Word -> Patricia a -> (Patricia a, Maybe a, Patricia a) +splitLookup !w = \t -> + case go t of + (# l, mx, r #) -> (l, mx, r) + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let !(# ll, mx, lr #) = go l + in (# ll, mx, rebinL p lr r #) + + else (# Nil, Nothing, t #) + + else if w <= upper p + then let !(# rl, mx, rr #) = go r + in (# rebinR p l rl, mx, rr #) + + else (# t, Nothing, Nil #) + + Tip k a -> + case w `Prelude.compare` k of + EQ -> (# Nil, Just a , Nil #) + GT -> (# t , Nothing, Nil #) + LT -> (# Nil, Nothing, t #) + + Nil -> (# Nil, Nothing, Nil #) + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filter :: (a -> Bool) -> Patricia a -> Patricia a +filter f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + + Tip _ a + | f a -> t + | otherwise -> Nil + + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filterWithKey :: (Word -> a -> Bool) -> Patricia a -> Patricia a +filterWithKey f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + + Tip k a + | f k a -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +mapMaybe :: (a -> Maybe b) -> Patricia a -> Patricia b +mapMaybe f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + + Tip k a -> + case f a of + Just b -> Tip k b + Nothing -> Nil + + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree +-- and create a tree out of 'Just' results. +mapMaybeWithKey :: (Word -> a -> Maybe b) -> Patricia a -> Patricia b +mapMaybeWithKey f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + + Tip k a -> + case f k a of + Just b -> Tip k b + Nothing -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partition :: (a -> Bool) -> Patricia a -> (Patricia a, Patricia a) +partition f = \t -> + case go t of + (# l, r #) -> (l, r) + where + go t = + case t of + Bin p l r -> + let !(# ll, lr #) = go l + !(# rl, rr #) = go r + + in (# rebin p ll rl, rebin p lr rr #) + + Tip _ a + | f a -> (# t, Nil #) + | otherwise -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partitionWithKey :: (Word -> a -> Bool) -> Patricia a -> (Patricia a, Patricia a) +partitionWithKey f = \t -> + case go t of + (# l, r #) -> (l, r) + where + go t = + case t of + Bin p l r -> + let !(# ll, lr #) = go l + !(# rl, rr #) = go r + + in (# rebin p ll rl, rebin p lr rr #) + + Tip k a + | f k a -> (# t, Nil #) + | otherwise -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +mapEither :: (a -> Either b c) -> Patricia a -> (Patricia b, Patricia c) +mapEither f = \t -> + case go t of + (# l, r #) -> (l, r) + where + go t = + case t of + Bin p l r -> + let !(# ll, lr #) = go l + !(# rl, rr #) = go r + + in (# rebin p ll rl, rebin p lr rr #) + + Tip k a -> + case f a of + Left b -> (# Tip k b, Nil #) + Right c -> (# Nil, Tip k c #) + + Nil -> (# Nil, Nil #) + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +mapEitherWithKey :: (Word -> a -> Either b c) -> Patricia a -> (Patricia b, Patricia c) +mapEitherWithKey f = \t -> + case go t of + (# l, r #) -> (l, r) + where + go t = + case t of + Bin p l r -> + let !(# ll, lr #) = go l + !(# rl, rr #) = go r + + in (# rebin p ll rl, rebin p lr rr #) + + Tip k a -> + case f k a of + Left b -> (# Tip k b, Nil #) + Right c -> (# Nil, Tip k c #) + + Nil -> (# Nil, Nil #) + + + +moduleLoc :: String +moduleLoc = "Patricia.Word.Lazy" + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the leftmost key in the tree. +lookupMin :: Patricia a -> Maybe a +lookupMin Nil = Nothing +lookupMin t = let !(# a #) = unsafeLookupMin t + in Just a + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMin :: Patricia a -> (# a #) +unsafeLookupMin t = + case t of + Bin _ l _ -> unsafeLookupMin l + Tip _ a -> (# a #) + Nil -> throw $ MalformedTree moduleLoc "lookupMin" + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the leftmost key in the tree. +lookupMinWithKey :: Patricia a -> Maybe (Lookup a) +lookupMinWithKey Nil = Nothing +lookupMinWithKey t = Just $! unsafeLookupMinWithKey t + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMinWithKey :: Patricia a -> Lookup a +unsafeLookupMinWithKey t = + case t of + Bin _ l _ -> unsafeLookupMinWithKey l + Tip k a -> Lookup k a + Nil -> throw $ MalformedTree moduleLoc "lookupMinWithKey" + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the rightmost key in the tree. +lookupMax :: Patricia a -> Maybe a +lookupMax Nil = Nothing +lookupMax t = let !(# a #) = unsafeLookupMax t + in Just a + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMax :: Patricia a -> (# a #) +unsafeLookupMax t = + case t of + Bin _ _ r -> unsafeLookupMax r + Tip _ a -> (# a #) + Nil -> throw $ MalformedTree moduleLoc "lookupMax" + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the rightmost key in the tree. +lookupMaxWithKey :: Patricia a -> Maybe (Lookup a) +lookupMaxWithKey Nil = Nothing +lookupMaxWithKey t = Just $! unsafeLookupMaxWithKey t + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMaxWithKey :: Patricia a -> Lookup a +unsafeLookupMaxWithKey t = + case t of + Bin _ _ r -> unsafeLookupMaxWithKey r + Tip k a -> Lookup k a + Nil -> throw $ MalformedTree moduleLoc "lookupMaxWithKey" + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Delete a value at the leftmost key in the tree. +deleteMin :: Patricia a -> Patricia a +deleteMin = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + _ -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Delete a value at the rightmost key in the tree. +deleteMax :: Patricia a -> Patricia a +deleteMax = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + _ -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Update a value at the leftmost key in the tree. +adjustMin :: (a -> a) -> Patricia a -> Patricia a +adjustMin f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) r + Tip k a -> Tip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Update a value at the leftmost key in the tree. +adjustMinWithKey :: (Word -> a -> a) -> Patricia a -> Patricia a +adjustMinWithKey f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) r + Tip k a -> Tip k (f k a) + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Update a value at the rightmost key in the tree. +adjustMax :: (a -> a) -> Patricia a -> Patricia a +adjustMax f = go + where + go t = + case t of + Bin p l r -> Bin p l (go r) + Tip k a -> Tip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Update a value at the rightmost key in the tree. +adjustMaxWithKey :: (Word -> a -> a) -> Patricia a -> Patricia a +adjustMaxWithKey f = go + where + go t = + case t of + Bin p l r -> Bin p l (go r) + Tip k a -> Tip k (f k a) + Nil -> Nil + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Update or delete a value at the leftmost key in the tree. +updateMin :: (a -> Maybe a) -> Patricia a -> Patricia a +updateMin f = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + Tip k a -> retip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Update or delete a value at the leftmost key in the tree. +updateMinWithKey :: (Word -> a -> Maybe a) -> Patricia a -> Patricia a +updateMinWithKey f = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + Tip k a -> retip k (f k a) + Nil -> Nil + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Update or delete a value at the rightmost key in the tree. +updateMax :: (a -> Maybe a) -> Patricia a -> Patricia a +updateMax f = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + Tip k a -> retip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(n,W))\). +-- Update or delete a value at the rightmost key in the tree. +updateMaxWithKey :: (Word -> a -> Maybe a) -> Patricia a -> Patricia a +updateMaxWithKey f = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + Tip k a -> retip k (f k a) + Nil -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the leftmost value and return it alongside the tree without it. +minView :: Patricia a -> Maybe (ViewL a) +minView Nil = Nothing +minView t = Just $! unsafeMinView t + +-- | The leftmost value with its key and the rest of the tree. +data ViewL a = ViewL {-# UNPACK #-} !(Lookup a) !(Patricia a) + deriving Show + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the leftmost value and return it alongside the tree without it. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeMinView :: Patricia a -> ViewL a +unsafeMinView t = + case t of + Bin p l r -> + let !(ViewL a l0) = unsafeMinView l + in ViewL a (rebinL p l0 r) + + Tip k a -> ViewL (Lookup k a) Nil + + Nil -> throw $ MalformedTree moduleLoc "minView" + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the rightmost value and return it alongside the tree without it. +maxView :: Patricia a -> Maybe (ViewR a) +maxView Nil = Nothing +maxView t = Just $! unsafeMaxView t + +-- | The rightmost value with its key and the rest of the tree. +data ViewR a = ViewR !(Patricia a) {-# UNPACK #-} !(Lookup a) + deriving Show + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the rightmost value and return it alongside the tree without it. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeMaxView :: Patricia a -> ViewR a +unsafeMaxView t = + case t of + Bin p l r -> + let !(ViewR r0 a) = unsafeMaxView r + in ViewR (rebinR p l r0) a + + Tip k a -> ViewR Nil (Lookup k a) + + Nil -> throw $ MalformedTree moduleLoc "maxView" diff --git a/src/Data/Patricia/Word/Lazy/TH.hs b/src/Data/Patricia/Word/Lazy/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Lazy/TH.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{-| + Template Haskell helper functions. + -} + +module Data.Patricia.Word.Lazy.TH where + +import Data.Patricia.Word.Lazy.Internal + +import Language.Haskell.TH.Syntax + + + +-- | \(\mathcal{O}(n)\). +-- Evaluate a tree of typed expressions. +sequenceCode :: Quote m => Patricia (Code m a) -> Code m (Patricia a) +sequenceCode t = + case t of + Bin p l r -> + [|| Bin + p + $$(sequenceCode l) + $$(sequenceCode r) + ||] + + Tip k a -> [|| Tip k $$(a) ||] + Nil -> [|| Nil ||] diff --git a/src/Data/Patricia/Word/Lazy/Unsafe.hs b/src/Data/Patricia/Word/Lazy/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Lazy/Unsafe.hs @@ -0,0 +1,75 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| + Data structure internals, helper operations and unsafe functions. + -} + +module Data.Patricia.Word.Lazy.Unsafe + ( Patricia (..) + + -- ** Bit operations + , Prefix + , Key + + -- | === Compare + , beyond + , upper + , lower + + -- | === Create + , Mask + , zeroBit + , mask + , branchingBit + + -- * Exceptions + , MalformedTree (..) + + -- * Range #range# + , Range (..) + + -- ** Map + , unsafeAdjustRange + , unsafeAdjustRangeWithKey + + -- ** Delete + , unsafeDeleteRange + + -- ** Update + , unsafeUpdateRange + , unsafeUpdateRangeWithKey + + -- ** Take + , unsafeTakeRange + + -- * Edges + -- ** Lookup + , Lookup (..) + + -- | === Min + , unsafeLookupMin + , unsafeLookupMinWithKey + + -- | === Max + , unsafeLookupMax + , unsafeLookupMaxWithKey + + -- ** View + -- | === Min + , ViewL (..) + , unsafeMinView + + -- | === Max + , ViewR (..) + , unsafeMaxView + + -- * Full-tree + -- ** Merge + , merge + ) where + +import Data.Patricia.Word.Common +import Data.Patricia.Word.Lazy.Internal +import Radix.Exception +import Radix.Word.Common +import Radix.Word.Foundation diff --git a/src/Data/Patricia/Word/Strict.hs b/src/Data/Patricia/Word/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Strict.hs @@ -0,0 +1,278 @@ +{-| + @'StrictPatricia' a@ is a spine-strict big-endian PATRICIA tree, a compressed + binary trie, using 'Word's as keys. + + == Laziness + + Evaluating the root of the tree (i.e. @(_ :: 'StrictPatricia' a)@) to + weak head normal form evaluates the entire spine of the tree to normal form. + + Functions do not perform any additional evaluations unless + their documentation directly specifies so. + + == Performance + + Each function's time complexity is provided in the documentation. + + \(n\) refers to the total number of entries in the tree. + Parts of the tree are denoted using subscripts: \(n_L\) refers to the left side, + \(n_R\) to the right side, \(n_I\) to a range (interval), and + \(n_M\) to entries collected with the use of a 'Monoid'. + + \(W\) is the size of 'Word' in bits, i.e. @'Data.Bits.finiteBitSize' (0 :: 'Word')@. + + == Implementation + + Description of the PATRICIA tree and some of the algorithms implemented can be found + within the following paper: + + * Chris Okasaki and Andy Gill, "/Fast Mergeable Integer Maps/", + Workshop on ML, September 1998, pages 77-86, + + -} + +module Data.Patricia.Word.Strict + ( StrictPatricia + , Patricia + + -- * Construct + , empty + , singleton + + -- ** Convert + , toLazy + + -- * Single-key + -- ** Lookup + , Data.Patricia.Word.Strict.Internal.lookup + , Data.Patricia.Word.Strict.Internal.find + , member + + -- *** Dirty + -- + -- | Dirty lookups omit intermediate checks and are thus faster for keys + -- that are in the tree, at the cost of being slower for keys not in the tree. + , dirtyLookup + , dirtyFind + , dirtyMember + + -- ** Insert + , insert + , insertWith + , insertWith' + + -- ** Map + , adjust + , adjust' + + -- ** Delete + , delete + + -- ** Update + , update + + , alter + + -- ** Take + , SplitLookup (..) + , splitLookup + + -- * Directional + -- ** Lookup + , Lookup (..) + , lookupL + , lookupR + + -- ** Map + -- | === Left + , adjustL + , adjustL' + , adjustLWithKey + , adjustLWithKey' + + -- | === Right + , adjustR + , adjustR' + , adjustRWithKey + , adjustRWithKey' + + -- ** Delete + , deleteL + , deleteR + + -- ** Update + -- | === Left + , updateL + , updateLWithKey + + -- | === Right + , updateR + , updateRWithKey + + -- ** Take + , Split (..) + + -- | === Left + , takeL + , splitL + + -- | === Right + , takeR + , splitR + + -- * Range + , Range (Range) + + -- ** Map + , adjustRange + , adjustRange' + + , adjustRangeWithKey + , adjustRangeWithKey' + + -- ** Delete + , deleteRange + + -- ** Update + , updateRange + , updateRangeWithKey + + -- ** Take + , takeRange + + -- * Edges + + -- ** Lookup + -- | === Min + , lookupMin + , lookupMinWithKey + + -- | === Max + , lookupMax + , lookupMaxWithKey + + -- ** Map + -- | === Min + , adjustMin + , adjustMin' + , adjustMinWithKey + , adjustMinWithKey' + + -- | === Max + , adjustMax + , adjustMax' + , adjustMaxWithKey + , adjustMaxWithKey' + + -- ** Delete + , deleteMin + , deleteMax + + -- ** Update + -- | === Min + , updateMin + , updateMinWithKey + + -- | === Max + , updateMax + , updateMaxWithKey + + -- ** View + -- | === Min + , ViewL (..) + , minView + + -- | === Max + , ViewR (..) + , maxView + + -- * Full tree + -- ** Size + , Data.Patricia.Word.Strict.Internal.null + , size + + -- ** Map + , Data.Patricia.Word.Strict.Internal.map + , map' + , mapWithKey + , mapWithKey' + + -- ** Fold + -- | === Left-to-right + , Data.Patricia.Word.Strict.Internal.foldl + , Data.Patricia.Word.Strict.Internal.foldl' + , foldlWithKey + , foldlWithKey' + + -- | === Right-to-left + , Data.Patricia.Word.Strict.Internal.foldr + , Data.Patricia.Word.Strict.Internal.foldr' + , foldrWithKey + , foldrWithKey' + + -- | === Monoid + , Data.Patricia.Word.Strict.Internal.foldMap + , foldMapWithKey + + -- ** Traverse + , Data.Patricia.Word.Strict.Internal.traverse + , traverseWithKey + + -- ** Filter + -- | === One side + , Data.Patricia.Word.Strict.Internal.filter + , filterWithKey + + , mapMaybe + , mapMaybeWithKey + + -- | === Both sides + , partition + , partitionWithKey + + , mapEither + , mapEitherWithKey + + -- ** Comparison + , PartialOrdering (..) + , Data.Patricia.Word.Strict.Internal.compare + + -- ** Union + , union + , unionL + , unionWith' + , unionWithKey' + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , disjoint + , intersection + , intersectionL + , intersectionWith' + , intersectionWithKey' + + -- ** Merge + -- | See 'Data.Patricia.Word.Strict.Unsafe.merge'. + ) where + +import Data.Patricia.Word.Common +import Data.Patricia.Word.Conversion +import Data.Patricia.Word.Strict.Internal +import Radix.Common +import Radix.Word.Common + + + +-- | \(\mathcal{O}(1)\). +-- Empty tree. +empty :: Patricia a +empty = Nil + +-- | \(\mathcal{O}(1)\). +-- Tree with a single entry. +singleton :: Word -> a -> Patricia a +singleton = Tip diff --git a/src/Data/Patricia/Word/Strict/Debug.hs b/src/Data/Patricia/Word/Strict/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Strict/Debug.hs @@ -0,0 +1,72 @@ +{-| + Safe functions for datatype introspection. + -} + +module Data.Patricia.Word.Strict.Debug + ( -- * Show + showsTree + + -- * Validate + , Validity (..) + , Reason (..) + , validate + ) where + +import Data.Patricia.Word.Debug +import Data.Patricia.Word.Strict.Internal +import Numeric.Long +import Radix.Word.Debug + + + +-- | \(\mathcal{O}(n)\). +-- Shows the internal structure of the tree. +showsTree :: (a -> ShowS) -> Patricia a -> ShowS +showsTree f = go 0 + where + go i t = + mappend (replicate i ' ') . + case t of + Bin p l r -> + showString "Bin " . showPrefix p . showChar '\n' + . go (i + 2) l . showChar '\n' + . go (i + 2) r + + Tip k a -> + showString "Tip " . showLongBin k . showString " => " . f a + + Nil -> showString "Nil" + + + +-- | \(\mathcal{O}(n)\). +-- Checks whether the tree is well-formed. +validate :: Patricia a -> Validity +validate t = + case t of + Bin p l r + | p == 0 -> Invalid ZeroPrefix + | otherwise -> + case go L p l of + Valid -> go R p r + err -> err + + Tip _ _ -> Valid + + Nil -> Valid + where + 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 -> + 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 + + Nil -> Invalid $ MalformedBin q diff --git a/src/Data/Patricia/Word/Strict/Internal.hs b/src/Data/Patricia/Word/Strict/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Strict/Internal.hs @@ -0,0 +1,3051 @@ +{-# LANGUAGE BangPatterns + , DeriveLift + , GADTs + , RankNTypes + , ScopedTypeVariables + , UnboxedTuples #-} + +module Data.Patricia.Word.Strict.Internal + ( StrictPatricia + , Patricia (..) + + , Data.Patricia.Word.Strict.Internal.null + , size + + , Data.Patricia.Word.Strict.Internal.map + , map' + , mapWithKey + , mapWithKey' + + , Data.Patricia.Word.Strict.Internal.foldl + , Data.Patricia.Word.Strict.Internal.foldl' + , foldlWithKey + , foldlWithKey' + + , Data.Patricia.Word.Strict.Internal.foldr + , Data.Patricia.Word.Strict.Internal.foldr' + , foldrWithKey + , foldrWithKey' + + , Data.Patricia.Word.Strict.Internal.foldMap + , foldMapWithKey + + , Data.Patricia.Word.Strict.Internal.traverse + , traverseWithKey + + , union + , unionL + , unionWith' + , unionWithKey' + + , difference + , differenceWith + , differenceWithKey + + , Data.Patricia.Word.Strict.Internal.compare + + , disjoint + , intersection + , intersectionL + , intersectionWith' + , intersectionWithKey' + + , merge + + , Data.Patricia.Word.Strict.Internal.lookup + , Data.Patricia.Word.Strict.Internal.find + , member + , takeOne + + , dirtyLookup + , dirtyFind + , dirtyMember + + , insert + , insertWith + , insertWith' + + , adjust + , adjust' + + , delete + + , update + + , alter + + , lookupL + , lookupR + + , adjustL + , adjustL' + , adjustLWithKey + , adjustLWithKey' + + , adjustR + , adjustR' + , adjustRWithKey + , adjustRWithKey' + + , deleteL + , deleteR + + , updateL + , updateR + , updateLWithKey + , updateRWithKey + + , adjustRange + , unsafeAdjustRange + + , adjustRange' + , unsafeAdjustRange' + + , adjustRangeWithKey + , unsafeAdjustRangeWithKey + + , adjustRangeWithKey' + , unsafeAdjustRangeWithKey' + + , deleteRange + , unsafeDeleteRange + + , updateRange + , unsafeUpdateRange + + , updateRangeWithKey + , unsafeUpdateRangeWithKey + + , takeRange + , unsafeTakeRange + + , takeL + , takeR + + , Split (..) + , splitL + , splitR + + , SplitLookup (..) + , splitLookup + + , Data.Patricia.Word.Strict.Internal.filter + , filterWithKey + + , mapMaybe + , mapMaybeWithKey + + , partition + , partitionWithKey + + , mapEither + , mapEitherWithKey + + , lookupMin + , lookupMinWithKey + , lookupMax + , lookupMaxWithKey + + , unsafeLookupMin + , unsafeLookupMinWithKey + , unsafeLookupMax + , unsafeLookupMaxWithKey + + , deleteMin + , deleteMax + + , adjustMin + , adjustMin' + , adjustMinWithKey + , adjustMinWithKey' + , adjustMax + , adjustMax' + , adjustMaxWithKey + , adjustMaxWithKey' + + , updateMin + , updateMinWithKey + , updateMax + , updateMaxWithKey + + , ViewL (..) + , minView + , unsafeMinView + + , ViewR (..) + , maxView + , unsafeMaxView + ) where + +import Data.Patricia.Word.Common +import Radix.Common +import Radix.Exception +import Radix.Word.Common +import Radix.Word.Foundation + +import Control.Applicative +import Control.DeepSeq +import Control.Exception (throw) +import Data.Bits +import Data.Foldable +import Data.Functor.Classes +import Language.Haskell.TH.Syntax (Lift) +import Text.Read +import Text.Show + + + +-- | Convenience synonym. +type StrictPatricia = Patricia + +-- | Spine-strict PATRICIA tree. +data Patricia a = Bin + {-# UNPACK #-} !Prefix + !(Patricia a) -- ^ Masked bit is @0@. + !(Patricia a) -- ^ Masked bit is @1@. + + | Tip + {-# UNPACK #-} !Key + a + + | Nil -- ^ Invariant: only allowed as the root of the tree. + deriving Lift + +instance Show a => Show (Patricia a) where + showsPrec = liftShowsPrec showsPrec showList + +instance Show1 Patricia where + liftShowsPrec showsPrec_ showList_ _ t = + showListWith (liftShowsPrec showsPrec_ showList_ 0) $ + foldrWithKey (\k a -> (:) (k, a)) [] t + +instance Read a => Read (Patricia a) where + readPrec = liftReadPrec readPrec readListPrec + +instance Read1 Patricia where + liftReadPrec readPrec_ readList_ = + fmap (Data.Foldable.foldl' (\z (k, a) -> insert k a z) Nil) + (liftReadListPrec readPrec_ readList_) + + +instance Eq a => Eq (Patricia a) where + (==) = liftEq (==) + +instance Eq1 Patricia where + liftEq eq = go + where + go l r = + case l of + Bin p xl xr -> + case r of + Bin q yl yr -> p == q && go xl yl && go xr yr + _ -> False + + Tip kA a -> + case r of + Tip kB b -> kA == kB && eq a b + _ -> False + + Nil -> + case r of + Nil -> True + _ -> False + + +-- | Uses 'Data.Patricia.Word.Strict.map'. +instance Functor Patricia where + fmap = Data.Patricia.Word.Strict.Internal.map + +instance Foldable Patricia where + foldl = Data.Patricia.Word.Strict.Internal.foldl + foldr = Data.Patricia.Word.Strict.Internal.foldr + foldMap = Data.Patricia.Word.Strict.Internal.foldMap + + foldl' = Data.Patricia.Word.Strict.Internal.foldl' + foldr' = Data.Patricia.Word.Strict.Internal.foldr' + + null = Data.Patricia.Word.Strict.Internal.null + length = fromIntegral . size + +instance Traversable Patricia where + traverse = Data.Patricia.Word.Strict.Internal.traverse + + +instance NFData a => NFData (Patricia a) where + rnf = liftRnf rnf + +instance NFData1 Patricia where + liftRnf nf = go + where + go t = + case t of + Bin _ l r -> go l `seq` go r + Tip _ a -> nf a + Nil -> () + + + +{-# INLINE join #-} +-- | Knowing that the prefices of two non-'Nil' trees disagree, construct a 'Bin'. +join :: Prefix -> Patricia a -> Prefix -> Patricia a -> Patricia a +join p0 t0 p1 t1 = + let m = branchingBit p0 p1 + + p = mask p0 m .|. m + + in if zeroBit p0 m + then Bin p t0 t1 + else Bin p t1 t0 + +{-# INLINE safeJoin #-} +-- | Knowing that the prefices of two trees disagree, construct a 'Bin'. +safeJoin :: Prefix -> Patricia a -> Prefix -> Patricia a -> Patricia a +safeJoin _ Nil _ t1 = t1 +safeJoin _ t0 _ Nil = t0 +safeJoin p0 t0 p1 t1 = join p0 t0 p1 t1 + +{-# INLINE rebin #-} +-- | Reconstruct a 'Bin' knowing that either of the sides may now be a 'Nil'. +rebin :: Prefix -> Patricia a -> Patricia a -> Patricia a +rebin p l r = + case l of + Nil -> r + _ -> + case r of + Nil -> l + _ -> Bin p l r + +{-# INLINE rebinL #-} +-- | Reconstruct a 'Bin' knowing that the left side may now be a 'Nil'. +rebinL :: Prefix -> Patricia a -> Patricia a -> Patricia a +rebinL p l r = + case l of + Nil -> r + _ -> Bin p l r + + +{-# INLINE rebinR #-} +-- | Reconstruct a 'Bin' knowing that the right side may now be a 'Nil'. +rebinR :: Prefix -> Patricia a -> Patricia a -> Patricia a +rebinR p l r = + case r of + Nil -> l + _ -> Bin p l r + + +{-# INLINE retip #-} +-- | Reconstruct a 'Tip' knowing that the value may not be there anymore. +retip :: Key -> Maybe a -> Patricia a +retip w (Just a) = Tip w a +retip _ Nothing = Nil + + + +-- | \(\mathcal{O}(1)\). +-- Check if the tree is empty. +null :: Patricia a -> Bool +null Nil = True +null _ = False + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of elements stored in the tree. +-- The returned number is guaranteed to be non-negative. +size :: Patricia a -> Int +size t = + case t of + Bin _ l r -> let !m = size l + !n = size r + in m + n + + Tip _ _ -> 1 + + Nil -> 0 + + + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +map :: (a -> b) -> Patricia a -> Patricia b +map f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) (go r) + Tip k a -> Tip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +-- +-- New values are evaluated to WHNF. +map' :: (a -> b) -> Patricia a -> Patricia b +map' f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) (go r) + Tip k a -> Tip k $! f a + Nil -> Nil + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +mapWithKey :: (Word -> a -> b) -> Patricia a -> Patricia b +mapWithKey f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) (go r) + Tip k a -> Tip k (f k a) + Nil -> Nil + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +-- +-- New values are evaluated to WHNF. +mapWithKey' :: (Word -> a -> b) -> Patricia a -> Patricia b +mapWithKey' f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) (go r) + Tip k a -> Tip k $! f k a + Nil -> Nil + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldl :: (b -> a -> b) -> b -> Patricia a -> b +foldl f = go + where + go z t = + case t of + Bin _ l r -> go (go z l) r + Tip _ a -> f z a + Nil -> z + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldlWithKey :: (b -> Word -> a -> b) -> b -> Patricia a -> b +foldlWithKey f = go + where + go z t = + case t of + Bin _ l r -> go (go z l) r + Tip k a -> f z k a + Nil -> z + + + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldl' :: (b -> a -> b) -> b -> Patricia a -> b +foldl' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z l + in go z' r + Tip _ a -> f z a + Nil -> z + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldlWithKey' :: (b -> Word -> a -> b) -> b -> Patricia a -> b +foldlWithKey' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z l + in go z' r + Tip k a -> f z k a + Nil -> z + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldr :: (a -> b -> b) -> b -> Patricia a -> b +foldr f = go + where + go z t = + case t of + Bin _ l r -> go (go z r) l + Tip _ a -> f a z + Nil -> z + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldrWithKey :: (Word -> a -> b -> b) -> b -> Patricia a -> b +foldrWithKey f = go + where + go z t = + case t of + Bin _ l r -> go (go z r) l + Tip k a -> f k a z + Nil -> z + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldr' :: (a -> b -> b) -> b -> Patricia a -> b +foldr' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z r + in go z' l + Tip _ a -> f a z + Nil -> z + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldrWithKey' :: (Word -> a -> b -> b) -> b -> Patricia a -> b +foldrWithKey' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z r + in go z' l + Tip k a -> f k a z + Nil -> z + + + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMap :: Monoid m => (a -> m) -> Patricia a -> m +foldMap f = go + where + go t = + case t of + Bin _ l r -> go l <> go r + Tip _ a -> f a + Nil -> mempty + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMapWithKey :: Monoid m => (Word -> a -> m) -> Patricia a -> m +foldMapWithKey f = go + where + go t = + case t of + Bin _ l r -> go l <> go r + Tip k a -> f k a + Nil -> mempty + + + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverse :: Applicative f => (a -> f b) -> Patricia a -> f (Patricia b) +traverse f = go + where + go t = + case t of + Bin p l r -> liftA2 (Bin p) (go l) (go r) + Tip k a -> Tip k <$> f a + Nil -> pure Nil + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverseWithKey :: Applicative f => (Word -> a -> f b) -> Patricia a -> f (Patricia b) +traverseWithKey f = go + where + go t = + case t of + Bin p l r -> liftA2 (Bin p) (go l) (go r) + Tip k a -> Tip k <$> f k a + Nil -> pure Nil + + + +type UBin a = (# Prefix, Patricia a, Patricia a #) + +type UTip a = (# Word, a #) + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Unbiased union of two trees. +union :: Patricia a -> Patricia a -> Patricia a +union = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip kA _ -> tipAny kA tA tB + + Nil -> tB + + tipAny kA tA tB = + case tB of + Bin pB lB rB -> tipBin kA tA (# pB, lB, rB #) tB + + Tip kB _ + | kA == kB -> tA + | otherwise -> join kA tA kB tB + + Nil -> tA + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip kB _ -> tipBin kB tB uA tA + + Nil -> tA + + tipBin kA tA (# pB, lB, rB #) tB + | beyond pB kA = join kA tA pB tB + | kA < pB = Bin pB (tipAny kA tA lB) rB + | otherwise = Bin pB lB (tipAny kA tA rB) + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> Bin pA lA (binAny uB tB rA) + | pA >= lower pB -> Bin pB (binAny uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny uA tA rB) + | pB >= lower pA -> Bin pA (binAny uB tB lA) rA + | otherwise -> no + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Left-biased union of two trees. +unionL :: Patricia a -> Patricia a -> Patricia a +unionL = + union_ $ \s k a b -> + let !(# c #) = case s of + L -> (# a #) + R -> (# b #) + in Tip k c + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Union of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +unionWith' + :: (a -> a -> a) + -> Patricia a + -> Patricia a + -> Patricia a +unionWith' f = + union_ $ \s k a b -> + Tip k $! case s of + L -> f a b + R -> f b a + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Union of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +unionWithKey' + :: (Word -> a -> a -> a) + -> Patricia a + -> Patricia a + -> Patricia a +unionWithKey' f = + union_ $ \s k a b -> + Tip k $! case s of + L -> f k a b + R -> f k b a + + + +{-# INLINE union_ #-} +union_ + :: (forall x y. S x y a a -> Key -> x -> y -> Patricia a) + -> Patricia a + -> Patricia a + -> Patricia a +union_ f = anyAny L + where + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> tB + + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB + + Tip kB b + | kA == kB -> f s kA a b + | otherwise -> join kA tA kB tB + + Nil -> tA + + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> + let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA tA + + Nil -> tA + + tipBin s uA@(# kA, _ #) tA (# pB, lB, rB #) tB + | beyond pB kA = join kA tA pB tB + | kA < pB = Bin pB (tipAny s uA tA lB) rB + | otherwise = Bin pB lB (tipAny s uA tA rB) + + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in Bin pA lA (binAny s' uB tB rA) + | pA >= lower pB -> Bin pB (binAny s uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny s uA tA rB) + | pB >= lower pA -> let !(# s' #) = other s + in Bin pA (binAny s' uB tB lA) rA + | otherwise -> no + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Difference of two trees. +difference :: Patricia a -> Patricia b -> Patricia a +difference = + difference_ $ \_ _ _ _ -> + Nil + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Difference of two trees with a combining function. +-- +-- The 'Maybe' is evaluated to WHNF. +differenceWith + :: (a -> b -> Maybe a) + -> Patricia a + -> Patricia b + -> Patricia a +differenceWith f = + difference_ $ \s k a b -> + retip k $ case s of + L -> f a b + R -> f b a + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Difference of two trees with a combining function. +-- +-- The 'Maybe' is evaluated to WHNF. +differenceWithKey + :: (Word -> a -> b -> Maybe a) + -> Patricia a + -> Patricia b + -> Patricia a +differenceWithKey f = + difference_ $ \s k a b -> + retip k $ case s of + L -> f k a b + R -> f k b a + + + +{-# INLINE difference_ #-} +difference_ + :: (forall x y. S x y a b -> Key -> x -> y -> Patricia a) + -> Patricia a + -> Patricia b + -> Patricia a +difference_ (f :: forall n o. S n o x y -> Key -> n -> o -> Patricia x) = anyAny L + where + anyAny + :: forall a b. S a b x y -> Patricia a -> Patricia b -> Patricia x + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> case s of + L -> tA + R -> tB + + tipAny + :: forall a b. S a b x y -> UTip a -> Patricia a -> Patricia b -> Patricia x + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB + + Tip kB b + | kA == kB -> f s kA a b + | otherwise -> case s of + L -> tA + R -> tB + + Nil -> case s of + L -> tA + R -> tB + + binAny + :: forall a b. S a b x y -> UBin a -> Patricia a -> Patricia b -> Patricia x + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA tA + + Nil -> case s of + L -> tA + R -> tB + + tipBin + :: forall a b. S a b x y -> UTip a -> Patricia a -> UBin b -> Patricia b -> Patricia x + tipBin s uA@(# kA, _ #) tA (# pB, lB, rB #) tB + | beyond pB kA = case s of + L -> tA + R -> tB + + | kA < pB = case s of + L -> tipAny s uA tA lB + R -> rebinL pB (tipAny s uA tA lB) rB + + | otherwise = case s of + L -> tipAny s uA tA rB + R -> rebinR pB lB (tipAny s uA tA rB) + + binBin + :: forall a b. S a b x y -> UBin a -> Patricia a -> UBin b -> Patricia b -> Patricia x + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = case s of + L -> tA + R -> tB + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> case s of + L -> rebinR pA lA (binAny R uB tB rA) + R -> binAny L uB tB rA + + | pA >= lower pB -> case s of + L -> binAny s uA tA lB + R -> rebinL pB (binAny s uA tA lB) rB + + | otherwise -> no + + GT | pA <= upper pB -> case s of + L -> binAny s uA tA rB + R -> rebinR pB lB (binAny s uA tA rB) + + | pB >= lower pA -> case s of + L -> rebinL pA (binAny R uB tB lA) rA + R -> binAny L uB tB lA + + | otherwise -> no + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Compare two trees with respect to set inclusion, +-- using the given equality function for intersecting keys. +-- If any intersecting keys hold unequal values, the trees are 'Incomparable'. +compare :: (a -> b -> Bool) -> Patricia a -> Patricia b -> PartialOrdering +compare (f :: x -> y -> Bool) = anyAny L + where + anyAny + :: forall a b. S a b x y -> Patricia a -> Patricia b -> PartialOrdering + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> case tB of + Nil -> Equal + _ -> Subset + + tipAny + :: forall a b. S a b x y -> UTip a -> Patricia a -> Patricia b -> PartialOrdering + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip kB b + | kA == kB -> let eq = case s of + L -> f a b + R -> f b a + in if eq + then Equal + else Incomparable + + | otherwise -> Incomparable + + Nil -> Superset + + binAny + :: forall a b. S a b x y -> UBin a -> Patricia a -> Patricia b -> PartialOrdering + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA + + Nil -> Superset + + tipBin + :: forall a b. S a b x y -> UTip a -> Patricia a -> UBin b -> PartialOrdering + tipBin s uA@(# kA, _ #) tA (# pB, lB, rB #) = + if beyond pB kA + then Incomparable + else limit s . tipAny s uA tA $ if kA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y -> UBin a -> Patricia a -> UBin b -> Patricia b -> PartialOrdering + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> order (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in limit s' $ binAny s' uB tB rA + + | pA >= lower pB -> limit s $ binAny s uA tA lB + + | otherwise -> Incomparable + + GT | pA <= upper pB -> limit s $ binAny s uA tA rB + + | pB >= lower pA -> let !(# s' #) = other s + + in limit s' $ binAny s' uB tB lA + + | otherwise -> Incomparable + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Determine whether two trees' key sets are disjoint. +disjoint :: Patricia a -> Patricia b -> Bool +disjoint = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip kA _ -> tipAny kA tA tB + + Nil -> True + + tipAny kA tA tB = + case tB of + Bin pB lB rB -> tipBin kA tA (# pB, lB, rB #) + + Tip kB _ -> kA /= kB + + Nil -> True + + binAny :: forall a b. UBin a -> Patricia a -> Patricia b -> Bool + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip kB _ -> tipBin kB tB uA + + Nil -> True + + tipBin kA tA (# pB, lB, rB #) + | beyond pB kA = True + | otherwise = tipAny kA tA $ if kA < pB + then lB + else rB + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> anyAny lA lB && anyAny rA rB + + LT | pB <= upper pA -> binAny uB tB rA + | pA >= lower pB -> binAny uA tA lB + | otherwise -> True + + GT | pA <= upper pB -> binAny uA tA rB + | pB >= lower pA -> binAny uB tB lA + | otherwise -> True + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Unbiased intersection of two trees. +intersection :: Patricia a -> Patricia a -> Patricia a +intersection = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip kA _ -> tipAny kA tA tB + + Nil -> Nil + + tipAny kA tA tB = + case tB of + Bin pB lB rB -> tipBin kA tA (# pB, lB, rB #) + + Tip kB _ + | kA == kB -> tA + | otherwise -> Nil + + Nil -> Nil + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip kB _ -> tipBin kB tB uA + + Nil -> Nil + + tipBin kA tA (# pB, lB, rB #) + | beyond pB kA = Nil + | otherwise = tipAny kA tA $ if kA < pB + then lB + else rB + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> binAny uB tB rA + | pA >= lower pB -> binAny uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny uA tA rB + | pB >= lower pA -> binAny uB tB lA + | otherwise -> Nil + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Left-biased intersection of two trees. +intersectionL :: Patricia a -> Patricia b -> Patricia a +intersectionL = + intersection_ $ \s k a b -> + let !(# c #) = case s of + L -> (# a #) + R -> (# b #) + in Tip k c + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Intersection of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +intersectionWith' + :: (a -> b -> c) + -> Patricia a + -> Patricia b + -> Patricia c +intersectionWith' f = + intersection_ $ \s k a b -> + Tip k $! case s of + L -> f a b + R -> f b a + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Intersection of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +intersectionWithKey' + :: (Word -> a -> b -> c) + -> Patricia a + -> Patricia b + -> Patricia c +intersectionWithKey' f = + intersection_ $ \s k a b -> + Tip k $! case s of + L -> f k a b + R -> f k b a + + + +{-# INLINE intersection_ #-} +intersection_ + :: (forall x y. S x y a b -> Key -> x -> y -> Patricia c) + -> Patricia a + -> Patricia b + -> Patricia c +intersection_ (f :: forall n o. S n o x y -> Word -> n -> o -> Patricia c) = + anyAny L + where + anyAny + :: forall a b. S a b x y -> Patricia a -> Patricia b -> Patricia c + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> Nil + + tipAny + :: forall a b. S a b x y -> UTip a -> Patricia a -> Patricia b -> Patricia c + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip kB b + | kA == kB -> f s kA a b + | otherwise -> Nil + + Nil -> Nil + + binAny + :: forall a b. S a b x y -> UBin a -> Patricia a -> Patricia b -> Patricia c + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA + + Nil -> Nil + + tipBin + :: forall a b. S a b x y -> UTip a -> Patricia a -> UBin b -> Patricia c + tipBin s uA@(# kA, _ #) tA (# pB, lB, rB #) + | beyond pB kA = Nil + | otherwise = tipAny s uA tA $ if kA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y -> UBin a -> Patricia a -> UBin b -> Patricia b -> Patricia c + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in binAny s' uB tB rA + | pA >= lower pB -> binAny s uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny s uA tA rB + | pB >= lower pA -> let !(# s' #) = other s + in binAny s' uB tB lA + | otherwise -> Nil + + + +{-# INLINE merge #-} +-- | \(\mathcal{O}(n_A + n_B)\). +-- General merge of two trees. +-- +-- Collision and single value functions __must__ return either +-- 'Tip' with the respective key, or 'Nil'. +-- +-- Subtree argument functions may return any tree, however the shape of said tree +-- __must__ be compatible with the prefix passed to the function. +-- +-- Resulting 'Patricia' trees in argument functions are evaluated to WHNF. +-- +-- This functions inlines when all argument functions are provided. +merge + :: (Key -> a -> b -> Patricia c) -- ^ Single value collision + -> (Key -> a -> Patricia c) -- ^ Single left value + -> (Prefix -> Patricia a -> Patricia a -> Patricia c) -- ^ Left subtree + -> (Key -> b -> Patricia c) -- ^ Single right value + -> (Prefix -> Patricia b -> Patricia b -> Patricia c) -- ^ Right subtree + -> Patricia a + -> Patricia b + -> Patricia c +merge (f :: Key -> x -> y -> Patricia c) oneX treeX oneY treeY = anyAny L + where + {-# INLINE side #-} + side one tree t = + case t of + Bin p l r -> tree p l r + Tip k a -> one k a + Nil -> Nil + + sideX = side oneX treeX + + sideY = side oneY treeY + + sideA :: forall a b. S a b x y -> Patricia a -> Patricia c + sideA s tA = case s of + L -> sideX tA + R -> sideY tA + + sideB :: forall a b. S a b x y -> Patricia b -> Patricia c + sideB s tB = case s of + L -> sideY tB + R -> sideX tB + + anyAny + :: forall a b. S a b x y -> Patricia a -> Patricia b -> Patricia c + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip kA a -> tipAny s (# kA, a #) tA tB + + Nil -> sideB s tB + + tipAny + :: forall a b. S a b x y -> UTip a -> Patricia a -> Patricia b -> Patricia c + tipAny s uA@(# kA, a #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip kB b + | kA == kB -> case s of + L -> f kA a b + R -> f kA b a + + | otherwise -> case s of + L -> safeJoin kA (oneX kA a) kB (sideY tB) + R -> safeJoin kA (oneY kA a) kB (sideX tB) + + Nil -> sideA s tA + + binAny + :: forall a b. S a b x y -> UBin a -> Patricia a -> Patricia b -> Patricia c + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip kB b -> let !(# s' #) = other s + in tipBin s' (# kB, b #) tB uA + + Nil -> sideA s tA + + tipBin + :: forall a b. S a b x y -> UTip a -> Patricia a -> UBin b -> Patricia c + tipBin s uA@(# kA, a #) tA (# pB, lB, rB #) + | beyond pB kA = case s of + L -> safeJoin kA (oneX kA a) pB (treeY pB lB rB) + R -> safeJoin kA (oneY kA a) pB (treeX pB lB rB) + + | kA < pB = rebin pB (tipAny s uA tA lB) (sideB s rB) + + | otherwise = rebin pB (sideB s lB) (tipAny s uA tA rB) + + binBin + :: forall a b. S a b x y -> UBin a -> Patricia a -> UBin b -> Patricia b -> Patricia c + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = case s of + L -> safeJoin pA (treeX pA lA rA) pB (treeY pB lB rB) + R -> safeJoin pA (treeY pA lA rA) pB (treeX pB lB rB) + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + + in rebin pA (sideA s lA) (binAny s' uB tB rA) + + | pA >= lower pB -> rebin pB (binAny s uA tA lB) (sideB s rB) + + | otherwise -> no + + GT | pA <= upper pB -> rebin pB (sideB s lB) (binAny s uA tA rB) + + | pB >= lower pA -> let !(# s' #) = other s + + in rebin pA (binAny s' uB tB lA) (sideA s rA) + + | otherwise -> no + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the value at a key in the tree. +lookup :: Word -> Patricia a -> Maybe a +lookup !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> Nothing + | w < p -> go l + | otherwise -> go r + + Tip k a + | k == w -> Just a + | otherwise -> Nothing + + Nil -> Nothing + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the value at a key in the tree, falling back to the given default value +-- if it does not exist. +find :: a -> Word -> Patricia a -> a +find d !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> d + | w < p -> go l + | otherwise -> go r + + Tip k a + | k == w -> a + | otherwise -> d + + Nil -> d + +-- | \(\mathcal{O}(\min(n,W))\). +-- Check whether the value exists at a key in the tree. +member :: Word -> Patricia a -> Bool +member !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> False + | w < p -> go l + | otherwise -> go r + + Tip k _ -> k == w + + Nil -> False + +-- 'lookup' that doesn't allocate a 'Maybe'. +takeOne :: Word -> Patricia a -> Patricia a +takeOne !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> Nil + | w < p -> go l + | otherwise -> go r + + Tip k _ + | k == w -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the value at a key in the tree. +dirtyLookup :: Word -> Patricia a -> Maybe a +dirtyLookup !w = go + where + go t = + case t of + Bin p l r + | w < p -> go l + | otherwise -> go r + + Tip k a + | k == w -> Just a + | otherwise -> Nothing + + Nil -> Nothing + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the value at a key in the tree, falling back to the default value +-- if it does not exist. +dirtyFind :: a -> Word -> Patricia a -> a +dirtyFind d !w = go + where + go t = + case t of + Bin p l r + | w < p -> go l + | otherwise -> go r + + Tip k a + | k == w -> a + | otherwise -> d + + Nil -> d + +-- | \(\mathcal{O}(\min(n,W))\). +-- Check whether the value exists at a key in the tree. +dirtyMember :: Word -> Patricia a -> Bool +dirtyMember !w = go + where + go t = + case t of + Bin p l r + | w < p -> go l + | otherwise -> go r + + Tip k _ -> k == w + + Nil -> False + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, it is replaced. +insert :: Word -> a -> Patricia a -> Patricia a +insert !w a = go + where + go t = + case t of + Bin p l r + | beyond p w -> join w (Tip w a) p t + | w < p -> Bin p (go l) r + | otherwise -> Bin p l (go r) + + Tip k _ + | k == w -> Tip k a + | otherwise -> join w (Tip w a) k t + + Nil -> Tip w a + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, the function is used instead. +insertWith :: (a -> a) -> Word -> a -> Patricia a -> Patricia a +insertWith f !w b = go + where + go t = + case t of + Bin p l r + | beyond p w -> join w (Tip w b) p t + | w < p -> Bin p (go l) r + | otherwise -> Bin p l (go r) + + Tip k a + | k == w -> Tip k (f a) + | otherwise -> join w (Tip w b) k t + + Nil -> Tip w b + +-- | \(\mathcal{O}(\min(n,W))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, the function is used instead. +-- +-- New value is evaluted to WHNF. +insertWith' :: (a -> a) -> Word -> a -> Patricia a -> Patricia a +insertWith' f !w b = go + where + go t = + case t of + Bin p l r + | beyond p w -> join w (b `seq` Tip w b) p t + | w < p -> Bin p (go l) r + | otherwise -> Bin p l (go r) + + Tip k a + | k == w -> Tip k $! f a + | otherwise -> join w (b `seq` Tip w b) k t + + Nil -> Tip w b + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Apply a function to a value in the tree at the given key. +adjust :: (a -> a) -> Word -> Patricia a -> Patricia a +adjust f !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> Bin p (go l) r + | otherwise -> Bin p l (go r) + + Tip k a + | k == w -> Tip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Apply a function to a value in the tree at the given key. +-- +-- New value is evaluated to WHNF. +adjust' :: (a -> a) -> Word -> Patricia a -> Patricia a +adjust' f !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> Bin p (go l) r + | otherwise -> Bin p l (go r) + + Tip k a + | k == w -> Tip k $! f a + | otherwise -> t + + Nil -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Delete a value in the tree at the given key. +delete :: Word -> Patricia a -> Patricia a +delete !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go l) r + | otherwise -> rebinR p l (go r) + + Tip k _ + | k == w -> Nil + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update or delete a value in the tree at the given key. +-- +-- The 'Maybe' is evaluated to WHNF. +update :: (a -> Maybe a) -> Word -> Patricia a -> Patricia a +update f !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go l) r + | otherwise -> rebinR p l (go r) + + Tip k a + | k == w -> retip k (f a) + | otherwise -> t + + Nil -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Insert, update or delete a value in the tree at the given key. +-- +-- The resulting 'Maybe' is evaluated to WHNF. +alter :: (Maybe a -> Maybe a) -> Word -> Patricia a -> Patricia a +alter f !w = go + where + go t = + case t of + Bin p l r + | beyond p w -> case f Nothing of + Just b -> join p t w (Tip w b) + Nothing -> t + + | w < p -> rebinL p (go l) r + | otherwise -> rebinR p l (go r) + + Tip k a + | k == w -> case f (Just a) of + Just b -> Tip k b + Nothing -> Nil + + | otherwise -> case f Nothing of + Just b -> join k t w (Tip w b) + Nothing -> t + + Nil -> case f Nothing of + Just b -> Tip w b + Nothing -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at a largest key smaller than or equal to the given key. +lookupL :: Word -> Patricia a -> Maybe (Lookup a) +lookupL !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go l + else Nothing + + else Just $! if w <= upper p + then case go r of + Just x -> x + Nothing -> unsafeLookupMaxWithKey l + + else unsafeLookupMaxWithKey r + + Tip k a + | k <= w -> Just $! Lookup k a + | otherwise -> Nothing + + Nil -> Nothing + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at a smallest key greater than or equal to the given key. +lookupR :: Word -> Patricia a -> Maybe (Lookup a) +lookupR !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then Just $! if w >= lower p + then case go l of + Just x -> x + Nothing -> unsafeLookupMinWithKey r + + else unsafeLookupMinWithKey l + + else if w <= upper p + then go r + else Nothing + + Tip k a + | k >= w -> Just $! Lookup k a + | otherwise -> Nothing + + Nil -> Nothing + + + +-- | \(\mathcal{O}(\min(n,W) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- or equal to the given one. +adjustL :: (a -> a) -> Word -> Patricia a -> Patricia a +adjustL f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go l) r + else t + + else Bin p (Data.Patricia.Word.Strict.Internal.map f l) $ + if w <= upper p + then go r + else Data.Patricia.Word.Strict.Internal.map f r + + Tip k a + | k <= w -> Tip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- or equal to the given one. +-- +-- New value is evaluated to WHNF. +adjustL' :: (a -> a) -> Word -> Patricia a -> Patricia a +adjustL' f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go l) r + else t + + else Bin p (map' f l) $ + if w <= upper p + then go r + else map' f r + + Tip k a + | k <= w -> Tip k $! f a + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- or equal to the given one. +adjustLWithKey :: (Word -> a -> a) -> Word -> Patricia a -> Patricia a +adjustLWithKey f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go l) r + else t + + else Bin p (mapWithKey f l) $ + if w <= upper p + then go r + else mapWithKey f r + + Tip k a + | k <= w -> Tip k (f k a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- or equal to the given one. +-- +-- New value is evaluated to WHNF. +adjustLWithKey' :: (Word -> a -> a) -> Word -> Patricia a -> Patricia a +adjustLWithKey' f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go l) r + else t + + else Bin p (mapWithKey' f l) $ + if w <= upper p + then go r + else mapWithKey' f r + + Tip k a + | k <= w -> Tip k $! f k a + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Delete values for which keys are smaller than or equal to the given one. +deleteL :: Word -> Patricia a -> Patricia a +deleteL !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go l) r + else t + + else if w <= upper p + then go r + else Nil + + Tip k _ + | k <= w -> Nil + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W) + n_L)\). +-- Update every value for which the key is smaller than or equal to the given one. +-- +-- The 'Maybe' is evaluated to WHNF. +updateL :: (a -> Maybe a) -> Word -> Patricia a -> Patricia a +updateL f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go l) r + else t + + else rebin p (mapMaybe f l) $ + if w <= upper p + then go r + else mapMaybe f r + + Tip k a + | k <= w -> retip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_L)\). +-- Update every value for which the key is smaller than or equal to the given one. +-- +-- The 'Maybe' is evaluated to WHNF. +updateLWithKey :: (Word -> a -> Maybe a) -> Word -> Patricia a -> Patricia a +updateLWithKey f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go l) r + else t + + else rebin p (mapMaybeWithKey f l) $ + if w <= upper p + then go r + else mapMaybeWithKey f r + + Tip k a + | k <= w -> retip k (f k a) + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Take values for which keys are smaller than or equal to the given one. +takeL :: Word -> Patricia a -> Patricia a +takeL !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go l + else Nil + + else if w <= upper p + then rebinR p l (go r) + else t + + Tip k _ + | k <= w -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(\min(n,W) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- or equal to the given one. +adjustR :: (a -> a) -> Word -> Patricia a -> Patricia a +adjustR f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else Data.Patricia.Word.Strict.Internal.map f l + + in Bin p l' (Data.Patricia.Word.Strict.Internal.map f r) + + else if w <= upper p + then Bin p l (go r) + else t + + Tip k a + | k >= w -> Tip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- or equal to the given one. +-- +-- New value is evaluated to WHNF. +adjustR' :: (a -> a) -> Word -> Patricia a -> Patricia a +adjustR' f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else map' f l + + in Bin p l' (map' f r) + + else if w <= upper p + then Bin p l (go r) + else t + + Tip k a + | k >= w -> Tip k $! f a + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- or equal to the given one. +adjustRWithKey :: (Word -> a -> a) -> Word -> Patricia a -> Patricia a +adjustRWithKey f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else mapWithKey f l + + in Bin p l' (mapWithKey f r) + + else if w <= upper p + then Bin p l (go r) + else t + + Tip k a + | k >= w -> Tip k (f k a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- or equal to the given one. +-- +-- New value is evaluated to WHNF. +adjustRWithKey' :: (Word -> a -> a) -> Word -> Patricia a -> Patricia a +adjustRWithKey' f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else mapWithKey' f l + + in Bin p l' (mapWithKey' f r) + + else if w <= upper p + then Bin p l (go r) + else t + + Tip k a + | k >= w -> Tip k $! f k a + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Delete values for which keys are greater than or equal to the given one. +deleteR :: Word -> Patricia a -> Patricia a +deleteR !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go l + else Nil + + else if w <= upper p + then rebinR p l (go r) + else t + + Tip k _ + | k >= w -> Nil + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W) + n_R)\). +-- Update every value for which the key is greater than or equal to the given one. +-- +-- The 'Maybe' is evaluated to WHNF. +updateR :: (a -> Maybe a) -> Word -> Patricia a -> Patricia a +updateR f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else mapMaybe f l + + in rebin p l' (mapMaybe f r) + + else if w <= upper p + then rebinR p l (go r) + else t + + Tip k a + | k >= w -> retip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_R)\). +-- Update every value for which the key is greater than or equal to the given one. +-- +-- The 'Maybe' is evaluated to WHNF. +updateRWithKey :: (Word -> a -> Maybe a) -> Word -> Patricia a -> Patricia a +updateRWithKey f !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then let l' = if w >= lower p + then go l + else mapMaybeWithKey f l + + in rebin p l' (mapMaybeWithKey f r) + + else if w <= upper p + then rebinR p l (go r) + else t + + Tip k a + | k >= w -> retip k (f k a) + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Take values for which keys are greater than or equal to the given one. +takeR :: Word -> Patricia a -> Patricia a +takeR !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go l) r + else t + + else if w <= upper p + then go r + else Nil + + Tip k _ + | k >= w -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +adjustRange :: (a -> a) -> Range -> Patricia a -> Patricia a +adjustRange f (UnsafeRange kL kR) + | kL == kR = adjust f kL + | otherwise = unsafeAdjustRange f kL kR + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeAdjustRange + :: (a -> a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeAdjustRange f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> Bin p (adjustR f wL l) (adjustL f wR r) + + LT | pM <= upper p -> Bin p l (go r) + | p >= lower pM -> if wL < p + then Bin p + (adjustR f wL l) + (Data.Patricia.Word.Strict.Internal.map f r) + + else Bin p l (adjustR f wL r) + + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then Bin p + (Data.Patricia.Word.Strict.Internal.map f l) + (adjustL f wR r) + + else Bin p (adjustL f wR l) r + + | pM >= lower p -> Bin p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> Tip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +-- +-- New value is evaluated to WHNF. +adjustRange' :: (a -> a) -> Range -> Patricia a -> Patricia a +adjustRange' f (UnsafeRange kL kR) + | kL == kR = adjust' f kL + | otherwise = unsafeAdjustRange' f kL kR + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +-- +-- New value is evaluated to WHNF. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeAdjustRange' + :: (a -> a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeAdjustRange' f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> Bin p (adjustR' f wL l) (adjustL' f wR r) + + LT | pM <= upper p -> Bin p l (go r) + | p >= lower pM -> if wL < p + then Bin p (adjustR' f wL l) (map' f r) + else Bin p l (adjustR' f wL r) + + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then Bin p (map' f l) (adjustL' f wR r) + else Bin p (adjustL' f wR l) r + + | pM >= lower p -> Bin p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> Tip k $! f a + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +adjustRangeWithKey :: (Word -> a -> a) -> Range -> Patricia a -> Patricia a +adjustRangeWithKey f (UnsafeRange kL kR) + | kL == kR = adjust (f kL) kL + | otherwise = unsafeAdjustRangeWithKey f kL kR + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeAdjustRangeWithKey + :: (Word -> a -> a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeAdjustRangeWithKey f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> Bin p (adjustRWithKey f wL l) (adjustLWithKey f wR r) + + LT | pM <= upper p -> Bin p l (go r) + | p >= lower pM -> if wL < p + then Bin p (adjustRWithKey f wL l) (mapWithKey f r) + else Bin p l (adjustRWithKey f wL r) + + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then Bin p (mapWithKey f l) (adjustLWithKey f wR r) + else Bin p (adjustLWithKey f wR l) r + + | pM >= lower p -> Bin p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> Tip k (f k a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +-- +-- New value is evaluated to WHNF. +adjustRangeWithKey' :: (Word -> a -> a) -> Range -> Patricia a -> Patricia a +adjustRangeWithKey' f (UnsafeRange kL kR) + | kL == kR = adjust' (f kL) kL + | otherwise = unsafeAdjustRangeWithKey' f kL kR + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Apply a function to every value for which the key is in the given range. +-- +-- New value is evaluated to WHNF. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeAdjustRangeWithKey' + :: (Word -> a -> a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeAdjustRangeWithKey' f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> Bin p (adjustRWithKey' f wL l) (adjustLWithKey' f wR r) + + LT | pM <= upper p -> Bin p l (go r) + | p >= lower pM -> if wL < p + then Bin p (adjustRWithKey' f wL l) (mapWithKey' f r) + else Bin p l (adjustRWithKey' f wL r) + + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then Bin p (mapWithKey' f l) (adjustLWithKey' f wR r) + else Bin p (adjustLWithKey' f wR l) r + + | pM >= lower p -> Bin p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> Tip k $! f k a + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Delete values for which keys are in the given range. +deleteRange :: Range -> Patricia a -> Patricia a +deleteRange (UnsafeRange kL kR) + | kL == kR = delete kL + | otherwise = unsafeDeleteRange kL kR + +-- | \(\mathcal{O}(\min(n,W))\). +-- Delete values for which keys are in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeDeleteRange + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeDeleteRange !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> rebin p (deleteR wL l) (deleteL wR r) + + LT | pM <= upper p -> rebinR p l (go r) + | p >= lower pM -> if wL < p + then deleteR wL l + else rebinR p l (deleteR wL r) + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then deleteL wR r + else rebinL p (deleteL wR l) r + + | pM >= lower p -> rebinL p (go l) r + | otherwise -> t + + Tip k _ + | k >= wL && k <= wR -> Nil + | otherwise -> t + + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Update every value for which the key is in the given range. +-- +-- The 'Maybe' is evaluated to WHNF. +updateRange :: (a -> Maybe a) -> Range -> Patricia a -> Patricia a +updateRange f (UnsafeRange kL kR) + | kL == kR = update f kL + | otherwise = unsafeUpdateRange f kL kR + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Update every value for which the key is in the given range. +-- +-- The 'Maybe' is evaluated to WHNF. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeUpdateRange + :: (a -> Maybe a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeUpdateRange f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> rebin p (updateR f wL l) (updateL f wR r) + + LT | pM <= upper p -> rebinR p l (go r) + | p >= lower pM -> if wL < p + then rebinL p (updateR f wL l) (mapMaybe f r) + else rebinR p l (updateR f wL r) + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then rebinR p (mapMaybe f l) (updateL f wR r) + else rebinL p (updateL f wR l) r + + | pM >= lower p -> rebinL p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> retip k (f a) + | otherwise -> t + + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Update every value for which the key is in the given range. +-- +-- The 'Maybe' is evaluated to WHNF. +updateRangeWithKey :: (Word -> a -> Maybe a) -> Range -> Patricia a -> Patricia a +updateRangeWithKey f (UnsafeRange kL kR) + | kL == kR = update (f kL) kL + | otherwise = unsafeUpdateRangeWithKey f kL kR + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Update every value for which the key is in the given range. +-- +-- The 'Maybe' is evaluated to WHNF. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeUpdateRangeWithKey + :: (Word -> a -> Maybe a) + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeUpdateRangeWithKey f !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> rebin p (updateRWithKey f wL l) (updateLWithKey f wR r) + + LT | pM <= upper p -> rebinR p l (go r) + | p >= lower pM -> if wL < p + then rebinL p (updateRWithKey f wL l) + (mapMaybeWithKey f r) + + else rebinR p l (updateRWithKey f wL r) + | otherwise -> t + + GT | p <= upper pM -> if wR >= p + then rebinR p (mapMaybeWithKey f l) + (updateLWithKey f wR r) + + else rebinL p (updateLWithKey f wR l) r + + | pM >= lower p -> rebinL p (go l) r + | otherwise -> t + + Tip k a + | k >= wL && k <= wR -> retip k (f k a) + | otherwise -> t + + Nil -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Take values for which keys are in the given range. +takeRange :: Range -> Patricia a -> Patricia a +takeRange (UnsafeRange kL kR) + | kL == kR = takeOne kL + | otherwise = unsafeTakeRange kL kR + +-- | \(\mathcal{O}(\min(n,W))\). +-- Take values for which keys are in the given range. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeTakeRange + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Patricia a + -> Patricia a +unsafeTakeRange !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> rebin p (takeR wL l) (takeL wR r) + + LT | pM <= upper p -> go r + | p >= lower pM -> if wL < p + then rebinL p (takeR wL l) r + else takeR wL r + + | otherwise -> Nil + + GT | p <= upper pM -> if wR >= p + then rebinR p l (takeL wR r) + else takeL wR l + + | pM >= lower p -> go l + | otherwise -> Nil + + Tip k _ + | k >= wL && k <= wR -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | Result of a tree split. +data Split l r = Split !(Patricia l) !(Patricia r) + deriving Show + +-- | \(\mathcal{O}(\min(n,W))\). +-- Split the tree into two, such that +-- values with keys smaller than or equal to the given one are on the left, +-- and values with keys greater than the given one are on the right. +splitL :: Word -> Patricia a -> Split a a +splitL !w = \t -> + case go t of + (# !l, !r #) -> Split l r + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let !(# !ll, !lr #) = go l + in (# ll, rebinL p lr r #) + + else (# Nil, t #) + + else if w <= upper p + then let !(# !rl, !rr #) = go r + in (# rebinR p l rl, rr #) + + else (# t, Nil #) + + Tip k _ + | w >= k -> (# t, Nil #) + | otherwise -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + +-- | \(\mathcal{O}(\min(n,W))\). +-- Split the tree into two, such that +-- values with keys smaller than the given one are on the left, +-- and values with keys greater than or equal to the given one are on the right. +splitR :: Word -> Patricia a -> Split a a +splitR !w = \t -> + case go t of + (# !l, !r #) -> Split l r + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let !(# !ll, !lr #) = go l + in (# ll, rebinL p lr r #) + + else (# Nil, t #) + + else if w <= upper p + then let !(# !rl, !rr #) = go r + in (# rebinR p l rl, rr #) + + else (# t, Nil #) + + Tip k _ + | w > k -> (# t, Nil #) + | otherwise -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + + + +-- | Result of a tree split with a lookup. +data SplitLookup l x r = SplitLookup !(Patricia l) !(Maybe x) !(Patricia r) + deriving Show + +-- | \(\mathcal{O}(\min(n,W))\). +-- Split the tree into two, such that +-- values with keys smaller than the given one are on the left, +-- values with keys greater than the given one are on the right, +-- and the value at the given key is returned separately. +splitLookup :: Word -> Patricia a -> SplitLookup a a a +splitLookup !w = \t -> + case go t of + (# !l, !mx, !r #) -> SplitLookup l mx r + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let !(# !ll, !mx, !lr #) = go l + in (# ll, mx, rebinL p lr r #) + + else (# Nil, Nothing, t #) + + else if w <= upper p + then let !(# !rl, !mx, !rr #) = go r + in (# rebinR p l rl, mx, rr #) + + else (# t, Nothing, Nil #) + + Tip k a -> + case w `Prelude.compare` k of + EQ -> (# Nil, Just a , Nil #) + GT -> (# t , Nothing, Nil #) + LT -> (# Nil, Nothing, t #) + + Nil -> (# Nil, Nothing, Nil #) + + + +-- | \(\mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filter :: (a -> Bool) -> Patricia a -> Patricia a +filter f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + + Tip _ a + | f a -> t + | otherwise -> Nil + + Nil -> Nil + +-- | \(\mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filterWithKey :: (Word -> a -> Bool) -> Patricia a -> Patricia a +filterWithKey f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + + Tip k a + | f k a -> t + | otherwise -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +-- +-- The 'Maybe' is evaluated to WHNF. +mapMaybe :: (a -> Maybe b) -> Patricia a -> Patricia b +mapMaybe f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + + Tip k a -> + case f a of + Just b -> Tip k b + Nothing -> Nil + + Nil -> Nil + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree +-- and create a tree out of 'Just' results. +-- +-- The 'Maybe' is evaluated to WHNF. +mapMaybeWithKey :: (Word -> a -> Maybe b) -> Patricia a -> Patricia b +mapMaybeWithKey f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + + Tip k a -> + case f k a of + Just b -> Tip k b + Nothing -> Nil + + Nil -> Nil + + + +-- | \(\mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partition :: (a -> Bool) -> Patricia a -> Split a a +partition f = \t -> + case go t of + (# !l, !r #) -> Split l r + where + go t = + case t of + Bin p l r -> + let !(# !ll, !lr #) = go l + !(# !rl, !rr #) = go r + + in (# rebin p ll rl, rebin p lr rr #) + + Tip _ a + | f a -> (# t, Nil #) + | otherwise -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + +-- | \(\mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partitionWithKey :: (Word -> a -> Bool) -> Patricia a -> Split a a +partitionWithKey f = \t -> + case go t of + (# !l, !r #) -> Split l r + where + go t = + case t of + Bin p l r -> + let !(# !ll, !lr #) = go l + !(# !rl, !rr #) = go r + + in (# rebin p ll rl, rebin p lr rr #) + + Tip k a + | f k a -> (# t, Nil #) + | otherwise -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +-- +-- The 'Either' is evaluated to WHNF. +mapEither :: (a -> Either b c) -> Patricia a -> Split b c +mapEither f = \t -> + case go t of + (# !l, !r #) -> Split l r + where + go t = + case t of + Bin p l r -> + let !(# !ll, !lr #) = go l + !(# !rl, !rr #) = go r + + in (# rebin p ll rl, rebin p lr rr #) + + Tip k a -> + case f a of + Left b -> (# Tip k b, Nil #) + Right c -> (# Nil, Tip k c #) + + Nil -> (# Nil, Nil #) + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +-- +-- The 'Either' is evaluated to WHNF. +mapEitherWithKey :: (Word -> a -> Either b c) -> Patricia a -> Split b c +mapEitherWithKey f = \t -> + case go t of + (# !l, !r #) -> Split l r + where + go t = + case t of + Bin p l r -> + let !(# !ll, !lr #) = go l + !(# !rl, !rr #) = go r + + in (# rebin p ll rl, rebin p lr rr #) + + Tip k a -> + case f k a of + Left b -> (# Tip k b, Nil #) + Right c -> (# Nil, Tip k c #) + + Nil -> (# Nil, Nil #) + + + +moduleLoc :: String +moduleLoc = "Patricia.Word.Strict" + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the leftmost key in the tree. +lookupMin :: Patricia a -> Maybe a +lookupMin Nil = Nothing +lookupMin t = let !(# a #) = unsafeLookupMin t + in Just a + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMin :: Patricia a -> (# a #) +unsafeLookupMin t = + case t of + Bin _ l _ -> unsafeLookupMin l + Tip _ a -> (# a #) + Nil -> throw $ MalformedTree moduleLoc "lookupMin" + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the leftmost key in the tree. +lookupMinWithKey :: Patricia a -> Maybe (Lookup a) +lookupMinWithKey Nil = Nothing +lookupMinWithKey t = Just $! unsafeLookupMinWithKey t + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMinWithKey :: Patricia a -> Lookup a +unsafeLookupMinWithKey t = + case t of + Bin _ l _ -> unsafeLookupMinWithKey l + Tip k a -> Lookup k a + Nil -> throw $ MalformedTree moduleLoc "lookupMinWithKey" + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the rightmost key in the tree. +lookupMax :: Patricia a -> Maybe a +lookupMax Nil = Nothing +lookupMax t = let !(# a #) = unsafeLookupMax t + in Just a + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMax :: Patricia a -> (# a #) +unsafeLookupMax t = + case t of + Bin _ _ r -> unsafeLookupMax r + Tip _ a -> (# a #) + Nil -> throw $ MalformedTree moduleLoc "lookupMax" + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the rightmost key in the tree. +lookupMaxWithKey :: Patricia a -> Maybe (Lookup a) +lookupMaxWithKey Nil = Nothing +lookupMaxWithKey t = Just $! unsafeLookupMaxWithKey t + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMaxWithKey :: Patricia a -> Lookup a +unsafeLookupMaxWithKey t = + case t of + Bin _ _ r -> unsafeLookupMaxWithKey r + Tip k a -> Lookup k a + Nil -> throw $ MalformedTree moduleLoc "lookupMaxWithKey" + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Delete a value at the leftmost key in the tree. +deleteMin :: Patricia a -> Patricia a +deleteMin = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + _ -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Delete a value at the rightmost key in the tree. +deleteMax :: Patricia a -> Patricia a +deleteMax = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + _ -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update a value at the leftmost key in the tree. +adjustMin :: (a -> a) -> Patricia a -> Patricia a +adjustMin f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) r + Tip k a -> Tip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update a value at the leftmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMin' :: (a -> a) -> Patricia a -> Patricia a +adjustMin' f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) r + Tip k a -> Tip k $! f a + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update a value at the leftmost key in the tree. +adjustMinWithKey :: (Word -> a -> a) -> Patricia a -> Patricia a +adjustMinWithKey f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) r + Tip k a -> Tip k (f k a) + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update a value at the leftmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMinWithKey' :: (Word -> a -> a) -> Patricia a -> Patricia a +adjustMinWithKey' f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) r + Tip k a -> Tip k $! f k a + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update a value at the rightmost key in the tree. +adjustMax :: (a -> a) -> Patricia a -> Patricia a +adjustMax f = go + where + go t = + case t of + Bin p l r -> Bin p l (go r) + Tip k a -> Tip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update a value at the rightmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMax' :: (a -> a) -> Patricia a -> Patricia a +adjustMax' f = go + where + go t = + case t of + Bin p l r -> Bin p l (go r) + Tip k a -> Tip k $! f a + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update a value at the rightmost key in the tree. +adjustMaxWithKey :: (Word -> a -> a) -> Patricia a -> Patricia a +adjustMaxWithKey f = go + where + go t = + case t of + Bin p l r -> Bin p l (go r) + Tip k a -> Tip k (f k a) + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update a value at the rightmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMaxWithKey' :: (Word -> a -> a) -> Patricia a -> Patricia a +adjustMaxWithKey' f = go + where + go t = + case t of + Bin p l r -> Bin p l (go r) + Tip k a -> Tip k $! f k a + Nil -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update or delete a value at the leftmost key in the tree. +-- +-- The 'Maybe' is evaluated to WHNF. +updateMin :: (a -> Maybe a) -> Patricia a -> Patricia a +updateMin f = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + Tip k a -> retip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update or delete a value at the leftmost key in the tree. +-- +-- The 'Maybe' is evaluated to WHNF. +updateMinWithKey :: (Word -> a -> Maybe a) -> Patricia a -> Patricia a +updateMinWithKey f = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + Tip k a -> retip k (f k a) + Nil -> Nil + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update or delete a value at the rightmost key in the tree. +-- +-- The 'Maybe' is evaluated to WHNF. +updateMax :: (a -> Maybe a) -> Patricia a -> Patricia a +updateMax f = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + Tip k a -> retip k (f a) + Nil -> Nil + +-- | \(\mathcal{O}(\min(n,W))\). +-- Update or delete a value at the rightmost key in the tree. +-- +-- The 'Maybe' is evaluated to WHNF. +updateMaxWithKey :: (Word -> a -> Maybe a) -> Patricia a -> Patricia a +updateMaxWithKey f = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + Tip k a -> retip k (f k a) + Nil -> Nil + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the leftmost value and return it alongside the tree without it. +minView :: Patricia a -> Maybe (ViewL a) +minView Nil = Nothing +minView t = Just $! unsafeMinView t + +-- | The leftmost value with its key and the rest of the tree. +data ViewL a = ViewL {-# UNPACK #-} !(Lookup a) !(Patricia a) + deriving Show + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the leftmost value and return it alongside the tree without it. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeMinView :: Patricia a -> ViewL a +unsafeMinView t = + case t of + Bin p l r -> + let !(ViewL a l0) = unsafeMinView l + in ViewL a (rebinL p l0 r) + + Tip k a -> ViewL (Lookup k a) Nil + + Nil -> throw $ MalformedTree moduleLoc "minView" + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the rightmost value and return it alongside the tree without it. +maxView :: Patricia a -> Maybe (ViewR a) +maxView Nil = Nothing +maxView t = Just $! unsafeMaxView t + +-- | The rightmost value with its key and the rest of the tree. +data ViewR a = ViewR !(Patricia a) {-# UNPACK #-} !(Lookup a) + deriving Show + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the rightmost value and return it alongside the tree without it. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeMaxView :: Patricia a -> ViewR a +unsafeMaxView t = + case t of + Bin p l r -> + let !(ViewR r0 a) = unsafeMaxView r + in ViewR (rebinR p l r0) a + + Tip k a -> ViewR Nil (Lookup k a) + + Nil -> throw $ MalformedTree moduleLoc "maxView" diff --git a/src/Data/Patricia/Word/Strict/TH.hs b/src/Data/Patricia/Word/Strict/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Strict/TH.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{-| + Template Haskell helper functions. + -} + +module Data.Patricia.Word.Strict.TH where + +import Data.Patricia.Word.Strict.Internal + +import Language.Haskell.TH.Syntax + + + +-- | \(\mathcal{O}(n)\). +-- Evaluate a tree of typed expressions. +sequenceCode :: Quote m => Patricia (Code m a) -> Code m (Patricia a) +sequenceCode t = + case t of + Bin p l r -> + [|| Bin + p + $$(sequenceCode l) + $$(sequenceCode r) + ||] + + Tip k a -> [|| Tip k $$(a) ||] + Nil -> [|| Nil ||] diff --git a/src/Data/Patricia/Word/Strict/Unsafe.hs b/src/Data/Patricia/Word/Strict/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Patricia/Word/Strict/Unsafe.hs @@ -0,0 +1,78 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| + Data structure internals, helper operations and unsafe functions. + -} + +module Data.Patricia.Word.Strict.Unsafe + ( Patricia (..) + + -- * Bit operations + , Prefix + , Key + + -- | === Compare + , beyond + , upper + , lower + + -- | === Create + , Mask + , zeroBit + , mask + , branchingBit + + -- * Exceptions + , MalformedTree (..) + + -- * Range #range# + , Range (..) + + -- ** Map + , unsafeAdjustRange + , unsafeAdjustRange' + + , unsafeAdjustRangeWithKey + , unsafeAdjustRangeWithKey' + + -- ** Delete + , unsafeDeleteRange + + -- ** Update + , unsafeUpdateRange + , unsafeUpdateRangeWithKey + + -- ** Take + , unsafeTakeRange + + -- * Edges + -- ** Lookup + , Lookup (..) + + -- | === Min + , unsafeLookupMin + , unsafeLookupMinWithKey + + -- | === Max + , unsafeLookupMax + , unsafeLookupMaxWithKey + + -- ** View + -- | === Min + , ViewL (..) + , unsafeMinView + + -- | === Max + , ViewR (..) + , unsafeMaxView + + -- * Full-tree + -- ** Merge + , merge + ) where + +import Data.Patricia.Word.Common +import Data.Patricia.Word.Strict.Internal +import Radix.Exception +import Radix.Word.Common +import Radix.Word.Foundation diff --git a/src/Data/Radix1Tree/Word8/Key.hs b/src/Data/Radix1Tree/Word8/Key.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Key.hs @@ -0,0 +1,58 @@ +{-| + Safe functions for building and destroying non-empty radix tree keys. + -} + +module Data.Radix1Tree.Word8.Key + ( -- * Build + Build1 + + -- ** Raw + , buildBytes + + -- ** ByteString + , buildByteString + , buildShortByteString + + -- ** Text + -- | See "Data.Radix1Tree.Word8.Key.Unsafe#g:build.text". + + -- * Feed + , Feed1 + + -- ** Raw + , feedBytes + + -- ** ByteString + -- | See "Data.Radix1Tree.Word8.Key.Unsafe#g:feed.bytestring". + + -- ** Text + -- | See "Data.Radix1Tree.Word8.Key.Unsafe#g:feed.text". + ) where + +import Data.RadixNTree.Word8.Key + +import qualified Data.ByteString as Strict (ByteString) +import Data.ByteString.Short (ShortByteString) +import Data.List.NonEmpty (NonEmpty) +import Data.Word + + + +-- | Convert the key into a non-empty list of bytes. +buildBytes :: Build1 -> NonEmpty Word8 +buildBytes = buildBytes1 + +-- | Convert the key into a non-empty strict 'Strict.ByteString'. +buildByteString :: Build1 -> Strict.ByteString +buildByteString = buildByteString1 + +-- | Convert the key into a non-empty 'ShortByteString'. +buildShortByteString :: Build1 -> ShortByteString +buildShortByteString = buildShortByteString1 + + + +{-# INLINE feedBytes #-} +-- | Convert the non-empty list of bytes into a key. +feedBytes :: NonEmpty Word8 -> Feed1 +feedBytes = feedBytes1 diff --git a/src/Data/Radix1Tree/Word8/Key/Unsafe.hs b/src/Data/Radix1Tree/Word8/Key/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Key/Unsafe.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| + Non-empty radix tree key internals, + and unsafe functions for building and destroying them. + -} + +module Data.Radix1Tree.Word8.Key.Unsafe + ( -- * Build + Build1 (..) + , YtpmeNon (..) + , Tsil (..) + + -- ** Text #build.text# + , unsafeBuildText + + -- * Feed + , Feed1 (..) + , Step (..) + + -- ** ByteString #feed.bytestring# + , unsafeFeedByteString + , unsafeFeedShortByteString + , unsafeFeedLazyByteString + + -- ** Text #feed.text# + , unsafeFeedText + , unsafeFeedLazyText + ) where + +import Data.ByteArray.NonEmpty (Step (..)) +import Data.RadixNTree.Word8.Key + +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import Data.ByteString.Short (ShortByteString) +import qualified Data.Text as Strict (Text) +import qualified Data.Text.Lazy as Lazy (Text) + + + +-- | Convert a key into a non-empty strict 'Strict.Text'. +-- +-- No checks are made to ensure the resulting value is a valid sequence +-- of UTF-8 code units. +unsafeBuildText :: Build1 -> Strict.Text +unsafeBuildText = unsafeBuildText1 + + + +{-# INLINE unsafeFeedByteString #-} +-- | Convert a strict 'Strict.ByteString' into a key. +-- +-- The 'Strict.ByteString' is assumed to be non-empty. +unsafeFeedByteString :: Strict.ByteString -> Feed1 +unsafeFeedByteString = unsafeFeedByteString1 + +{-# INLINE unsafeFeedShortByteString #-} +-- | Convert a 'ShortByteString' into a key. +-- +-- The 'ShortByteString' is assumed to be non-empty. +unsafeFeedShortByteString :: ShortByteString -> Feed1 +unsafeFeedShortByteString = unsafeFeedShortByteString1 + +{-# INLINE unsafeFeedLazyByteString #-} +-- | Convert a lazy 'Lazy.ByteString', in the form of the first chunk plus the rest, +-- into a key. +-- +-- The first chunk is assumed to be non-empty. +unsafeFeedLazyByteString :: Strict.ByteString -> Lazy.ByteString -> Feed1 +unsafeFeedLazyByteString = unsafeFeedLazyByteString1 + + + +{-# INLINE unsafeFeedText #-} +-- | Convert a strict 'Strict.Text' into a key. +-- +-- The 'Strict.Text' is assumed to be non-empty. +unsafeFeedText :: Strict.Text -> Feed1 +unsafeFeedText = unsafeFeedText1 + +{-# INLINE unsafeFeedLazyText #-} +-- | Convert a lazy 'Lazy.Text', in the form of the first chunk plus the rest, +-- into a key. +-- +-- The first chunk is assumed to be non-empty. +unsafeFeedLazyText :: Strict.Text -> Lazy.Text -> Feed1 +unsafeFeedLazyText = unsafeFeedLazyText1 diff --git a/src/Data/Radix1Tree/Word8/Lazy.hs b/src/Data/Radix1Tree/Word8/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Lazy.hs @@ -0,0 +1,791 @@ +{-| + @'LazyRadix1Tree' a@ is a spine-lazy radix tree that uses byte-aligned + non-empty byte sequences as keys. + + == Laziness + + Evaluating any particular entry in the tree to WHNF forces the evaluation + of the part of the spine leading up to that entry to normal form. + + == Performance + + Each function's time complexity is provided in the documentation. + + Laziness-amortized functions specify two time complexities: + time to construct the return value (denoted with a \(\texttt{+}\)) and time to + fully apply the function to the tree. + + \(x\) is the length of the input key. + + \(k\) is the length of the longest key stored in the tree. + + \(n\) refers to the total number of entries in the tree. + Parts of the tree are denoted using subscripts: \(n_L\) refers to the left side, + \(n_R\) to the right side, and \(n_M\) to entries collected with the use of a 'Monoid'. + + == Inlining + + Functions that produce and consume 'Feed1's are treated specially within the library, + as when combined they can be reduced in a manner similar to the + [destroy/unfoldr elimination rule](https://wiki.haskell.org/Correctness_of_short_cut_fusion#destroy.2Funfoldr). + + The elimination in this library is achieved by inlining both types of functions + heavily. To avoid unnecessary code duplication during compilation consider creating + helper functions that apply these functions one to another, e.g. + + @updateBS f bs = 'update' f ('Data.Radix1Tree.Word8.Key.Unsafe.unsafeFeedByteString' bs)@ + + N.B. To inline properly functions that consume 'Feed1's must mention all of the + arguments except for the tree. + + == Implementation + + See the implementation section in "Data.RadixTree.Word8.Strict.Unsafe" + for the explanation of the innerworkings. + + See the implementation section in "Data.Patricia.Word.Strict" for literary references. + -} + +module Data.Radix1Tree.Word8.Lazy + ( LazyRadix1Tree + , Radix1Tree + + , RadixTree (..) + + -- * Key + , module Data.Radix1Tree.Word8.Key + + -- * Construct + , empty + , singleton + + -- ** Convert + , toStrict + + -- * Single-key + -- ** Lookup + , Data.Radix1Tree.Word8.Lazy.lookup + , Data.Radix1Tree.Word8.Lazy.find + , Data.Radix1Tree.Word8.Lazy.member + , subtree + + -- *** Chunked + -- + -- | Chunked lookup allows providing the key piece by piece while retaining + -- the ability to check for early failure. + -- + -- Note that while 'subtree' can be used to achieve the same result, + -- it is more expensive allocation-wise, as it must ensure that + -- the resulting tree is well-formed after each chunk application. + , Cursor + , cursor + , move + , stop + , Location (..) + , locate + + -- ** Insert + , insert + , insertWith + + -- ** Map + , adjust + + -- ** Delete + , delete + , prune + + -- ** Update + , update + , alter + , shape + + -- ** Take + , splitLookup + + -- * Directional + , Openness (..) + + -- ** Lookup + , Lookup (..) + , lookupL + , lookupR + + -- ** Map + -- | === Left + , adjustL + , adjustLWithKey + + -- | === Right + , adjustR + , adjustRWithKey + + -- ** Update + -- | === Left + , updateL + , updateLWithKey + + -- | === Right + , updateR + , updateRWithKey + + -- ** Take + -- | === Left + , takeL + , splitL + + -- | === Right + , takeR + + -- * Edges + + -- ** Lookup + -- | === Min + , lookupMin + , lookupMinWithKey + + -- | === Max + , lookupMax + , lookupMaxWithKey + + -- ** Map + -- | === Min + , adjustMin + , adjustMinWithKey + + -- | === Max + , adjustMax + , adjustMaxWithKey + + -- ** Delete + , deleteMin + , deleteMax + + -- ** Update + -- | === Min + , updateMin + , updateMinWithKey + + -- | === Max + , updateMax + , updateMaxWithKey + + -- ** View + -- | === Min + , ViewL (..) + , minView + + -- | === Max + , ViewR (..) + , maxView + + -- * Full tree + -- ** Size + , Data.Radix1Tree.Word8.Lazy.null + , size + + -- ** Extend + , prefix + + -- ** Map + , Data.Radix1Tree.Word8.Lazy.map + , mapWithKey + + -- ** Fold + -- | === Left-to-right + , Data.Radix1Tree.Word8.Lazy.foldl + , Data.Radix1Tree.Word8.Lazy.foldl' + , foldlWithKey + , foldlWithKey' + + -- | === Right-to-left + , Data.Radix1Tree.Word8.Lazy.foldr + , Data.Radix1Tree.Word8.Lazy.foldr' + , foldrWithKey + , foldrWithKey' + + -- | === Monoid + , Data.Radix1Tree.Word8.Lazy.foldMap + , foldMapWithKey + + -- ** Traverse + , Data.Radix1Tree.Word8.Lazy.traverse + , traverseWithKey + + -- ** Filter + -- | === One side + , Data.Radix1Tree.Word8.Lazy.filter + , filterWithKey + + , mapMaybe + , mapMaybeWithKey + + -- | === Both sides + , partition + , partitionWithKey + + , mapEither + , mapEitherWithKey + + -- ** Comparison + , PartialOrdering (..) + , Data.Radix1Tree.Word8.Lazy.compare + + -- ** Union + , union + , unionL + , unionWith + , unionWithKey + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , disjoint + , intersection + , intersectionL + , intersectionWith + , intersectionWithKey + + -- ** Merge + -- | See 'Data.Radix1Tree.Word8.Lazy.Unsafe.merge'. + ) where + +import Data.Radix1Tree.Word8.Key +import Data.RadixNTree.Word8.Common +import Data.RadixNTree.Word8.Conversion +import Data.RadixNTree.Word8.Lazy +import Radix.Common + + + +-- | \(\mathcal{O}(1)\). +-- Empty tree. +empty :: Radix1Tree a +empty = empty1 + +{-# INLINE singleton #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(x)\). +-- Tree with a single entry. +singleton :: Feed1 -> a -> Radix1Tree a +singleton = singleton1 + + +-- | \(\mathcal{O}(n)\). +-- Create a strict 'Strict.Patricia' tree from a lazy one. +-- +-- The resulting tree does not share its data representation with the original. +toStrict :: LazyRadix1Tree a -> StrictRadix1Tree a +toStrict = toStrict1 + + + +-- | \(\mathcal{O}(1)\). +-- Check if the tree is empty. +null :: Radix1Tree a -> Bool +null = null1 + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of elements stored in the tree. +-- The returned number is guaranteed to be non-negative. +size :: Radix1Tree a -> Int +size = size1 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree. +map :: (a -> b) -> Radix1Tree a -> Radix1Tree b +map = map1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree. +mapWithKey :: (Build1 -> a -> b) -> Radix1Tree a -> Radix1Tree b +mapWithKey = mapWithKey1 + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldl :: (b -> a -> b) -> b -> Radix1Tree a -> b +foldl = Data.RadixNTree.Word8.Lazy.foldl1 + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldlWithKey :: (b -> Build1 -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey = foldlWithKey1 + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldl' :: (b -> a -> b) -> b -> Radix1Tree a -> b +foldl' = foldl1' + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldlWithKey' :: (b -> Build1 -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey' = foldlWithKey1' + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldr :: (a -> b -> b) -> b -> Radix1Tree a -> b +foldr = Data.RadixNTree.Word8.Lazy.foldr1 + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldrWithKey :: (Build1 -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey = foldrWithKey1 + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldr' :: (a -> b -> b) -> b -> Radix1Tree a -> b +foldr' = foldr1' + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldrWithKey' :: (Build1 -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey' = foldrWithKey1' + + + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMap :: Monoid m => (a -> m) -> Radix1Tree a -> m +foldMap = foldMap1 + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMapWithKey :: Monoid m => (Build1 -> a -> m) -> Radix1Tree a -> m +foldMapWithKey = foldMapWithKey1 + + + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverse :: Applicative f => (a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverse = traverse1 + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverseWithKey + :: Applicative f => (Build1 -> a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverseWithKey = traverseWithKey1 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filter :: (a -> Bool) -> Radix1Tree a -> Radix1Tree a +filter = filter1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filterWithKey :: (Build1 -> a -> Bool) -> Radix1Tree a -> Radix1Tree a +filterWithKey = filterWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +mapMaybe :: (a -> Maybe b) -> Radix1Tree a -> Radix1Tree b +mapMaybe = mapMaybe1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +mapMaybeWithKey :: (Build1 -> a -> Maybe b) -> Radix1Tree a -> Radix1Tree b +mapMaybeWithKey = mapMaybeWithKey1 + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partition :: (a -> Bool) -> Radix1Tree a -> (Radix1Tree a, Radix1Tree a) +partition = partition1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partitionWithKey :: (Build1 -> a -> Bool) -> Radix1Tree a -> (Radix1Tree a, Radix1Tree a) +partitionWithKey = partitionWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +mapEither :: (a -> Either b c) -> Radix1Tree a -> (Radix1Tree b, Radix1Tree c) +mapEither = mapEither1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +mapEitherWithKey :: (Build1 -> a -> Either b c) -> Radix1Tree a -> (Radix1Tree b, Radix1Tree c) +mapEitherWithKey = mapEitherWithKey1 + + + +{-# INLINE lookup #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the value at a key in the tree. +lookup :: Feed1 -> Radix1Tree a -> Maybe a +lookup = lookup1 + +{-# INLINE find #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the value at a key in the tree, falling back to the given default value +-- if it does not exist. +find :: a -> Feed1 -> Radix1Tree a -> a +find = find1 + +{-# INLINE member #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Check whether the value exists at a key in the tree. +member :: Feed1 -> Radix1Tree a -> Bool +member = member1 + +{-# INLINE subtree #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the part of the tree below the given prefix. +subtree :: Feed1 -> Radix1Tree a -> RadixTree a +subtree = subtree1 + +{-# INLINE prefix #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(x)\). +-- Prefix the root of the tree with the given key. +prefix :: Feed1 -> RadixTree a -> Radix1Tree a +prefix = prefix1 + + +-- | \(\mathcal{O}(1)\). +-- Make a cursor that points to the root of the tree. +cursor :: Radix1Tree a -> Cursor a +cursor = cursor1 + +{-# INLINE move #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Move the cursor down by the extent of the given key. +move :: Feed1 -> Cursor a -> Cursor a +move = move1 + + + +{-# INLINE insert #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, it is replaced. +insert :: Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insert = insert1 + +{-# INLINE insertWith #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, the function is used instead. +insertWith :: (a -> a) -> Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insertWith = insertWith1 + + +{-# INLINE adjust #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Apply a function to a value in the tree at the given key. +adjust :: (a -> a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjust = adjust1 + + +{-# INLINE delete #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Delete a value in the tree at the given key. +delete :: Feed1 -> Radix1Tree a -> Radix1Tree a +delete = delete1 + +{-# INLINE prune #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Delete values in the tree below the given key. +prune :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +prune = prune1 + + +{-# INLINE update #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Update or delete a value in the tree at the given key. +update :: (a -> Maybe a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +update = update1 + + +{-# INLINE alter #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Insert, update or delete a value in the tree at the given key. +alter :: (Maybe a -> Maybe a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +alter = alter1 + + +{-# INLINE shape #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Update the part of the tree at the given prefix. +shape :: (RadixTree a -> RadixTree a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +shape = shape1 + + +{-# INLINE splitLookup #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Split the tree into two, such that +-- values with keys smaller than the given one are on the left, +-- values with keys greater than the given one are on the right, +-- and the value at the given key is returned separately. +splitLookup :: Feed1 -> Radix1Tree a -> (Radix1Tree a, Maybe a, Radix1Tree a) +splitLookup = splitLookup1 + + + +{-# INLINE lookupL #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up a value at a largest key smaller than (or equal to) the given key. +lookupL :: Openness -> Feed1 -> Radix1Tree a -> Maybe (Lookup1 a) +lookupL = lookupL1 + + +{-# INLINE lookupR #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up a value at a smallest key greater than (or equal to) the given key. +lookupR :: Openness -> Feed1 -> Radix1Tree a -> Maybe (Lookup1 a) +lookupR = lookupR1 + + + +{-# INLINE adjustL #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +adjustL :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustL = adjustL1 + +{-# INLINE adjustLWithKey #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +adjustLWithKey :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustLWithKey = adjustLWithKey1 + + + +{-# INLINE adjustR #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +adjustR :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustR = adjustR1 + +{-# INLINE adjustRWithKey #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +adjustRWithKey :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustRWithKey = adjustRWithKey1 + + + +{-# INLINE updateL #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_L)\). +-- Update every value for which the key is smaller than (or equal to) the given one. +updateL :: (a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateL = updateL1 + +{-# INLINE updateLWithKey #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_L)\). +-- Update every value for which the key is smaller than (or equal to) the given one. +updateLWithKey :: (Build1 -> a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateLWithKey = updateLWithKey1 + +{-# INLINE updateR #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_R)\). +-- Update every value for which the key is greater than (or equal to) the given one. +updateR :: (a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateR = updateR1 + +{-# INLINE updateRWithKey #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_R)\). +-- Update every value for which the key is greater than (or equal to) the given one. +updateRWithKey :: (Build1 -> a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateRWithKey = updateRWithKey1 + + + +{-# INLINE takeL #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Take values for which keys are smaller than (or equal to) the given one. +takeL :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +takeL = takeL1 + +{-# INLINE takeR #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Take values for which keys are greater than (or equal to) the given one. +takeR :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +takeR = takeR1 + + + +{-# INLINE splitL #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Split the tree into two, such that +-- values with keys smaller than (or equal to) the given one are on the left, +-- and the rest are on the right. +splitL :: Openness -> Feed1 -> Radix1Tree a -> (Radix1Tree a, Radix1Tree a) +splitL = splitL1 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +lookupMin :: Radix1Tree a -> Maybe a +lookupMin = lookupMin1 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +lookupMinWithKey :: Radix1Tree a -> Maybe (Lookup1 a) +lookupMinWithKey = lookupMinWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Delete a value at the leftmost key in the tree. +deleteMin :: Radix1Tree a -> Radix1Tree a +deleteMin = deleteMin1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +adjustMin :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMin = adjustMin1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +adjustMinWithKey :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMinWithKey = adjustMinWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +updateMin :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMin = updateMin1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +updateMinWithKey :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMinWithKey = updateMinWithKey1 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the leftmost value and return it alongside the tree without it. +minView :: Radix1Tree a -> Maybe (ViewL1 a) +minView = minView1 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +lookupMax :: Radix1Tree a -> Maybe a +lookupMax = lookupMax1 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +lookupMaxWithKey :: Radix1Tree a -> Maybe (Lookup1 a) +lookupMaxWithKey = lookupMaxWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Delete a value at the rightmost key in the tree. +deleteMax :: Radix1Tree a -> Radix1Tree a +deleteMax = deleteMax1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +adjustMax :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMax = adjustMax1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +adjustMaxWithKey :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMaxWithKey = adjustMaxWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +updateMax :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMax = updateMax1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +updateMaxWithKey :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMaxWithKey = updateMaxWithKey1 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the rightmost value and return it alongside the tree without it. +maxView :: Radix1Tree a -> Maybe (ViewR1 a) +maxView = maxView1 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Unbiased union of two trees. +union :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +union = union1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Left-biased union of two trees. +unionL :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionL = unionL1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Union of two trees with a combining function. +unionWith :: (a -> a -> a) -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionWith = unionWith1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Union of two trees with a combining function. +unionWithKey :: (Build1 -> a -> a -> a) -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionWithKey = unionWithKey1 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees. +difference :: Radix1Tree a -> Radix1Tree b -> Radix1Tree a +difference = difference1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees with a combining function. +differenceWith :: (a -> b -> Maybe a) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree a +differenceWith = differenceWith1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees with a combining function. +differenceWithKey + :: (Build1 -> a -> b -> Maybe a) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree a +differenceWithKey = differenceWithKey1 + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Compare two trees with respect to set inclusion, +-- using the given equality function for intersecting keys. +-- If any intersecting keys hold unequal values, the trees are 'Incomparable'. +compare :: (a -> b -> Bool) -> Radix1Tree a -> Radix1Tree b -> PartialOrdering +compare = compare1 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Determine whether two trees' key sets are disjoint. +disjoint :: Radix1Tree a -> Radix1Tree b -> Bool +disjoint = disjoint1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Unbiased intersection of two trees. +intersection :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +intersection = intersection1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Left-biased intersection of two trees. +intersectionL :: Radix1Tree a -> Radix1Tree b -> Radix1Tree a +intersectionL = intersectionL1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Intersection of two trees with a combining function. +intersectionWith :: (a -> b -> c) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c +intersectionWith = intersectionWith1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Intersection of two trees with a combining function. +intersectionWithKey :: (Build1 -> a -> b -> c) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c +intersectionWithKey = intersectionWithKey1 diff --git a/src/Data/Radix1Tree/Word8/Lazy/Debug.hs b/src/Data/Radix1Tree/Word8/Lazy/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Lazy/Debug.hs @@ -0,0 +1,30 @@ +{-| + Safe functions for datatype introspection. + -} + +module Data.Radix1Tree.Word8.Lazy.Debug + ( -- * Show + showsTree + + -- * Validate + , Validity (..) + , Reason (..) + , validate + ) where + +import Data.RadixNTree.Word8.Lazy (Radix1Tree) +import Data.RadixNTree.Word8.Lazy.Debug + + + +-- | \(\mathcal{O}(n)\). +-- Shows the internal structure of the tree. +showsTree :: (a -> ShowS) -> Radix1Tree a -> ShowS +showsTree = showsTree1 + + + +-- | \(\mathcal{O}(n)\). +-- Checks whether the tree is well-formed. +validate :: Radix1Tree a -> Validity +validate = validate1 diff --git a/src/Data/Radix1Tree/Word8/Lazy/TH.hs b/src/Data/Radix1Tree/Word8/Lazy/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Lazy/TH.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{-| + Template Haskell helper functions. + -} + +module Data.Radix1Tree.Word8.Lazy.TH + ( sequenceCode + ) where + +import Data.RadixNTree.Word8.Lazy.TH + +import Language.Haskell.TH.Syntax + + + +-- | \(\mathcal{O}(n)\). +-- Evaluate a tree of typed expressions. +sequenceCode :: Quote m => Radix1Tree (Code m a) -> Code m (Radix1Tree a) +sequenceCode = sequenceCode1 diff --git a/src/Data/Radix1Tree/Word8/Lazy/Unsafe.hs b/src/Data/Radix1Tree/Word8/Lazy/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Lazy/Unsafe.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE UnboxedTuples #-} + +{-# OPTIONS_HADDOCK not-home #-} + +{-| + Data structure internals, helper operations and unsafe functions. + -} + +module Data.Radix1Tree.Word8.Lazy.Unsafe + ( Radix1Tree (..) + + -- * Bit operations + , Prefix + , Key + + -- | === Compare + , beyond + , upper + , lower + + -- | === Create + , Mask + , zeroBit + , mask + , branchingBit + + -- * Exceptions + , MalformedTree (..) + + -- * Edges + -- ** Lookup + , Lookup1 (..) + + -- | === Min + , unsafeLookupMin + , unsafeLookupMinWithKey + + -- | === Max + , unsafeLookupMax + , unsafeLookupMaxWithKey + + -- ** Map + -- | === Min + , unsafeAdjustMin + , unsafeAdjustMinWithKey + + -- | === Max + , unsafeAdjustMax + , unsafeAdjustMaxWithKey + + -- ** Delete + , unsafeDeleteMin + , unsafeDeleteMax + + -- ** Update + -- | === Min + , unsafeUpdateMin + , unsafeUpdateMinWithKey + + -- | === Max + , unsafeUpdateMax + , unsafeUpdateMaxWithKey + + -- ** View + -- | === Min + , ViewL1 (..) + , unsafeMinView + + -- | === Max + , ViewR1 (..) + , unsafeMaxView + + -- * Full-tree + -- ** Merge + , merge + ) where + +import Data.RadixNTree.Word8.Key +import Data.RadixNTree.Word8.Common +import Data.RadixNTree.Word8.Lazy +import Radix.Exception +import Radix.Word.Foundation + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMin :: Radix1Tree a -> (# a #) +unsafeLookupMin = unsafeLookupMin1 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMinWithKey :: Radix1Tree a -> Lookup1 a +unsafeLookupMinWithKey = unsafeLookupMinWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Delete a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeDeleteMin :: Radix1Tree a -> Radix1Tree a +unsafeDeleteMin = unsafeDeleteMin1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMin :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMin = unsafeAdjustMin1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMinWithKey :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMinWithKey = unsafeAdjustMinWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeUpdateMin :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMin = unsafeUpdateMin1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeUpdateMinWithKey :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMinWithKey = unsafeUpdateMinWithKey1 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the leftmost value and return it alongside the tree without it. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeMinView :: Radix1Tree a -> ViewL1 a +unsafeMinView = unsafeMinView1 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMax :: Radix1Tree a -> (# a #) +unsafeLookupMax = unsafeLookupMax1 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMaxWithKey :: Radix1Tree a -> Lookup1 a +unsafeLookupMaxWithKey = unsafeLookupMaxWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Delete a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeDeleteMax :: Radix1Tree a -> Radix1Tree a +unsafeDeleteMax = unsafeDeleteMax1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMax :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMax = unsafeAdjustMax1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMaxWithKey :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMaxWithKey = unsafeAdjustMaxWithKey1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeUpdateMax :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMax = unsafeUpdateMax1 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeUpdateMaxWithKey :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMaxWithKey = unsafeUpdateMaxWithKey1 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the rightmost value and return it alongside the tree without it. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeMaxView :: Radix1Tree a -> ViewR1 a +unsafeMaxView = unsafeMaxView1 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- General merge of two trees. +-- +-- Resulting 'Maybe's and 'Radix1Tree's in argument functions are evaluated to WHNF. +-- +-- This functions inlines when all argument functions are provided. +{-# INLINE merge #-} +merge + :: (Build1 -> a -> b -> Maybe c) -- ^ Single value collision + -> (Build1 -> a -> Maybe c) -- ^ Single left value + -> (Build -> Radix1Tree a -> Radix1Tree c) -- ^ Left subtree + -> (Build1 -> b -> Maybe c) -- ^ Single right value + -> (Build -> Radix1Tree b -> Radix1Tree c) -- ^ Right subtree + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +merge = merge1 diff --git a/src/Data/Radix1Tree/Word8/Strict.hs b/src/Data/Radix1Tree/Word8/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Strict.hs @@ -0,0 +1,928 @@ +{-| + @'StrictRadix1Tree' a@ is a spine-strict radix tree that uses byte-aligned + non-empty byte sequences as keys. + + == Laziness + + Evaluating the root of the tree (i.e. @(_ :: 'StrictRadix1Tree' a)@) to + weak head normal form evaluates the entire spine of the tree to normal form. + + Functions do not perform any additional evaluations unless + their documentation directly specifies so. + + == Performance + + Each function's time complexity is provided in the documentation. + + \(x\) is the length of the input key. + + \(k\) is the length of the longest key stored in the tree. + + \(n\) refers to the total number of entries in the tree. + Parts of the tree are denoted using subscripts: \(n_L\) refers to the left side, + \(n_R\) to the right side, and \(n_M\) to entries collected with the use of a 'Monoid'. + + == Inlining + + Functions that produce and consume 'Feed1's are treated specially within the library, + as when combined they can be reduced in a manner similar to the + [destroy/unfoldr elimination rule](https://wiki.haskell.org/Correctness_of_short_cut_fusion#destroy.2Funfoldr). + + The elimination in this library is achieved by inlining both types of functions + heavily. To avoid unnecessary code duplication during compilation consider creating + helper functions that apply these functions one to another, e.g. + + @updateBS f bs = 'update' f ('Data.Radix1Tree.Word8.Key.Unsafe.unsafeFeedByteString' bs)@ + + N.B. To inline properly functions that consume 'Feed1's must mention all of the + arguments except for the tree. + + == Implementation + + See the implementation section in "Data.RadixTree.Word8.Strict.Unsafe" + for the explanation of the innerworkings. + + See the implementation section in "Data.Patricia.Word.Strict" for literary references. + -} + +module Data.Radix1Tree.Word8.Strict + ( StrictRadix1Tree + , Radix1Tree + + , RadixTree (..) + + -- * Key + , module Data.Radix1Tree.Word8.Key + + -- * Construct + , empty + , singleton + + -- ** Convert + , toLazy + + -- * Single-key + -- ** Lookup + , Data.Radix1Tree.Word8.Strict.lookup + , Data.Radix1Tree.Word8.Strict.find + , Data.Radix1Tree.Word8.Strict.member + , subtree + + -- *** Chunked + -- + -- | Chunked lookup allows providing the key piece by piece while retaining + -- the ability to check for early failure. + -- + -- Note that while 'subtree' can be used to achieve the same result, + -- it is more expensive allocation-wise, as it must ensure that + -- the resulting tree is well-formed after each chunk application. + , Cursor + , cursor + , move + , stop + , Location (..) + , locate + + -- ** Insert + , insert + , insertWith + , insertWith' + + -- ** Map + , adjust + , adjust' + + -- ** Delete + , delete + , prune + + -- ** Update + , update + , alter + , shape + + -- ** Take + , SplitLookup1 (..) + , splitLookup + + -- * Directional + , Openness (..) + + -- ** Lookup + , Lookup1 (..) + , lookupL + , lookupR + + -- ** Map + -- | === Left + , adjustL + , adjustL' + , adjustLWithKey + , adjustLWithKey' + + -- | === Right + , adjustR + , adjustR' + , adjustRWithKey + , adjustRWithKey' + + -- ** Update + -- | === Left + , updateL + , updateLWithKey + + -- | === Right + , updateR + , updateRWithKey + + -- ** Take + , Split1 (..) + + -- | === Left + , takeL + , splitL + + -- | === Right + , takeR + + -- * Edges + + -- ** Lookup + -- | === Min + , lookupMin + , lookupMinWithKey + + -- | === Max + , lookupMax + , lookupMaxWithKey + + -- ** Map + -- | === Min + , adjustMin + , adjustMin' + , adjustMinWithKey + , adjustMinWithKey' + + -- | === Max + , adjustMax + , adjustMax' + , adjustMaxWithKey + , adjustMaxWithKey' + + -- ** Delete + , deleteMin + , deleteMax + + -- ** Update + -- | === Min + , updateMin + , updateMinWithKey + + -- | === Max + , updateMax + , updateMaxWithKey + + -- ** View + -- | === Min + , ViewL1 (..) + , minView + + -- | === Max + , ViewR1 (..) + , maxView + + -- * Full tree + -- ** Size + , Data.Radix1Tree.Word8.Strict.null + , size + + -- ** Extend + , prefix + + -- ** Map + , Data.Radix1Tree.Word8.Strict.map + , map' + , mapWithKey + , mapWithKey' + + -- ** Fold + -- | === Left-to-right + , Data.Radix1Tree.Word8.Strict.foldl + , Data.Radix1Tree.Word8.Strict.foldl' + , foldlWithKey + , foldlWithKey' + + -- | === Right-to-left + , Data.Radix1Tree.Word8.Strict.foldr + , Data.Radix1Tree.Word8.Strict.foldr' + , foldrWithKey + , foldrWithKey' + + -- | === Monoid + , Data.Radix1Tree.Word8.Strict.foldMap + , foldMapWithKey + + -- ** Traverse + , Data.Radix1Tree.Word8.Strict.traverse + , traverseWithKey + + -- ** Filter + -- | === One side + , Data.Radix1Tree.Word8.Strict.filter + , filterWithKey + + , mapMaybe + , mapMaybeWithKey + + -- | === Both sides + , partition + , partitionWithKey + + , mapEither + , mapEitherWithKey + + -- ** Comparison + , PartialOrdering (..) + , Data.Radix1Tree.Word8.Strict.compare + + -- ** Union + , union + , unionL + , unionWith' + , unionWithKey' + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , disjoint + , intersection + , intersectionL + , intersectionWith' + , intersectionWithKey' + + -- ** Merge + -- | See 'Data.Radix1Tree.Word8.Strict.Unsafe.merge'. + ) where + +import Data.Radix1Tree.Word8.Key +import Data.RadixNTree.Word8.Common +import Data.RadixNTree.Word8.Conversion +import Data.RadixNTree.Word8.Strict +import Radix.Common + + + +-- | \(\mathcal{O}(1)\). +-- Empty tree. +empty :: Radix1Tree a +empty = empty1 + +{-# INLINE singleton #-} +-- | \(\mathcal{O}(x)\). +-- Tree with a single entry. +singleton :: Feed1 -> a -> Radix1Tree a +singleton = singleton1 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Create a lazy 'Lazy.Patricia' tree from a strict one. +-- +-- The resulting tree does not share its data representation with the original. +toLazy :: StrictRadix1Tree a -> LazyRadix1Tree a +toLazy = toLazy1 + + + +-- | \(\mathcal{O}(1)\). +-- Check if the tree is empty. +null :: Radix1Tree a -> Bool +null = null1 + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of elements stored in the tree. +-- The returned number is guaranteed to be non-negative. +size :: Radix1Tree a -> Int +size = size1 + + + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +map :: (a -> b) -> Radix1Tree a -> Radix1Tree b +map = map1 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +map' :: (a -> b) -> Radix1Tree a -> Radix1Tree b +map' = map1' + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +mapWithKey :: (Build1 -> a -> b) -> Radix1Tree a -> Radix1Tree b +mapWithKey = mapWithKey1 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +mapWithKey' :: (Build1 -> a -> b) -> Radix1Tree a -> Radix1Tree b +mapWithKey' = mapWithKey1' + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldl :: (b -> a -> b) -> b -> Radix1Tree a -> b +foldl = Data.RadixNTree.Word8.Strict.foldl1 + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldlWithKey :: (b -> Build1 -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey = foldlWithKey1 + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldl' :: (b -> a -> b) -> b -> Radix1Tree a -> b +foldl' = foldl1' + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldlWithKey' :: (b -> Build1 -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey' = foldlWithKey1' + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldr :: (a -> b -> b) -> b -> Radix1Tree a -> b +foldr = Data.RadixNTree.Word8.Strict.foldr1 + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldrWithKey :: (Build1 -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey = foldrWithKey1 + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldr' :: (a -> b -> b) -> b -> Radix1Tree a -> b +foldr' = foldr1' + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldrWithKey' :: (Build1 -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey' = foldrWithKey1' + + + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMap :: Monoid m => (a -> m) -> Radix1Tree a -> m +foldMap = foldMap1 + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMapWithKey :: Monoid m => (Build1 -> a -> m) -> Radix1Tree a -> m +foldMapWithKey = foldMapWithKey1 + + + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverse :: Applicative f => (a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverse = traverse1 + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverseWithKey + :: Applicative f => (Build1 -> a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverseWithKey = traverseWithKey1 + + + +-- | \(\mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filter :: (a -> Bool) -> Radix1Tree a -> Radix1Tree a +filter = filter1 + +-- | \(\mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filterWithKey :: (Build1 -> a -> Bool) -> Radix1Tree a -> Radix1Tree a +filterWithKey = filterWithKey1 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +-- +-- The 'Maybe' is evaluated to WHNF. +mapMaybe :: (a -> Maybe b) -> Radix1Tree a -> Radix1Tree b +mapMaybe = mapMaybe1 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +-- +-- The 'Maybe' is evaluated to WHNF. +mapMaybeWithKey :: (Build1 -> a -> Maybe b) -> Radix1Tree a -> Radix1Tree b +mapMaybeWithKey = mapMaybeWithKey1 + + +-- | \(\mathcal{O}(n)\). +-- Split1 the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partition :: (a -> Bool) -> Radix1Tree a -> Split1 a a +partition = partition1 + +-- | \(\mathcal{O}(n)\). +-- Split1 the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partitionWithKey :: (Build1 -> a -> Bool) -> Radix1Tree a -> Split1 a a +partitionWithKey = partitionWithKey1 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +-- +-- The 'Either' is evaluated to WHNF. +mapEither :: (a -> Either b c) -> Radix1Tree a -> Split1 b c +mapEither = mapEither1 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +-- +-- The 'Either' is evaluated to WHNF. +mapEitherWithKey :: (Build1 -> a -> Either b c) -> Radix1Tree a -> Split1 b c +mapEitherWithKey = mapEitherWithKey1 + + + +{-# INLINE lookup #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the value at a key in the tree. +lookup :: Feed1 -> Radix1Tree a -> Maybe a +lookup = lookup1 + +{-# INLINE find #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the value at a key in the tree, falling back to the given default value +-- if it does not exist. +find :: a -> Feed1 -> Radix1Tree a -> a +find = find1 + +{-# INLINE member #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Check whether the value exists at a key in the tree. +member :: Feed1 -> Radix1Tree a -> Bool +member = member1 + +{-# INLINE subtree #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the part of the tree below the given prefix. +subtree :: Feed1 -> Radix1Tree a -> RadixTree a +subtree = subtree1 + +{-# INLINE prefix #-} +-- | \(\mathcal{O}(x)\). +-- Prefix the root of the tree with the given key. +prefix :: Feed1 -> RadixTree a -> Radix1Tree a +prefix = prefix1 + + +-- | \(\mathcal{O}(1)\). +-- Make a cursor that points to the root of the tree. +cursor :: Radix1Tree a -> Cursor a +cursor = cursor1 + +{-# INLINE move #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Move the cursor down by the extent of the given key. +move :: Feed1 -> Cursor a -> Cursor a +move = move1 + + + +{-# INLINE insert #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, it is replaced. +insert :: Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insert = insert1 + +{-# INLINE insertWith #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, the function is used instead. +insertWith :: (a -> a) -> Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insertWith = insertWith1 + +{-# INLINE insertWith' #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, the function is used instead. +-- +-- New value is evaluated to WHNF. +insertWith' :: (a -> a) -> Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insertWith' = insertWith1' + + +{-# INLINE adjust #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Apply a function to a value in the tree at the given key. +adjust :: (a -> a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjust = adjust1 + +{-# INLINE adjust' #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Apply a function to a value in the tree at the given key. +-- +-- New value is evaluated to WHNF. +adjust' :: (a -> a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjust' = adjust1' + + +{-# INLINE delete #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Delete a value in the tree at the given key. +delete :: Feed1 -> Radix1Tree a -> Radix1Tree a +delete = delete1 + +{-# INLINE prune #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Delete values in the tree below the given key. +prune :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +prune = prune1 + + +{-# INLINE update #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Update or delete a value in the tree at the given key. +-- +-- The 'Maybe' is evaluated to WHNF. +update :: (a -> Maybe a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +update = update1 + + +{-# INLINE alter #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Insert, update or delete a value in the tree at the given key. +-- +-- The resulting 'Maybe' is evaluated to WHNF. +alter :: (Maybe a -> Maybe a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +alter = alter1 + + +{-# INLINE shape #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Update the part of the tree at the given prefix. +-- +-- The resulting 'Radix1Tree' is evaluated to WHNF. +shape :: (RadixTree a -> RadixTree a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +shape = shape1 + + +{-# INLINE splitLookup #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Split1 the tree into two, such that +-- values with keys smaller than the given one are on the left, +-- values with keys greater than the given one are on the right, +-- and the value at the given key is returned separately. +splitLookup :: Feed1 -> Radix1Tree a -> SplitLookup1 a a a +splitLookup = splitLookup1 + + + +{-# INLINE lookupL #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up a value at a largest key smaller than (or equal to) the given key. +lookupL :: Openness -> Feed1 -> Radix1Tree a -> Maybe (Lookup1 a) +lookupL = lookupL1 + + +{-# INLINE lookupR #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up a value at a smallest key greater than (or equal to) the given key. +lookupR :: Openness -> Feed1 -> Radix1Tree a -> Maybe (Lookup1 a) +lookupR = lookupR1 + + + +{-# INLINE adjustL #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +adjustL :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustL = adjustL1 + +{-# INLINE adjustL' #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +-- +-- New value is evaluated to WHNF. +adjustL' :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustL' = adjustL1' + +{-# INLINE adjustLWithKey #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +adjustLWithKey :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustLWithKey = adjustLWithKey1 + +{-# INLINE adjustLWithKey' #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +-- +-- New value is evaluated to WHNF. +adjustLWithKey' :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustLWithKey' = adjustLWithKey1' + + + +{-# INLINE adjustR #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +adjustR :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustR = adjustR1 + +{-# INLINE adjustR' #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +-- +-- New value is evaluated to WHNF. +adjustR' :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustR' = adjustR1' + +{-# INLINE adjustRWithKey #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +adjustRWithKey :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustRWithKey = adjustRWithKey1 + +{-# INLINE adjustRWithKey' #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +-- +-- New value is evaluated to WHNF. +adjustRWithKey' :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustRWithKey' = adjustRWithKey1' + + + +{-# INLINE updateL #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Update every value for which the key is smaller than (or equal to) the given one. +updateL :: (a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateL = updateL1 + +{-# INLINE updateLWithKey #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Update every value for which the key is smaller than (or equal to) the given one. +-- +-- The 'Maybe' is evaluated to WHNF. +updateLWithKey :: (Build1 -> a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateLWithKey = updateLWithKey1 + +{-# INLINE updateR #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Update every value for which the key is greater than (or equal to) the given one. +updateR :: (a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateR = updateR1 + +{-# INLINE updateRWithKey #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Update every value for which the key is greater than (or equal to) the given one. +-- +-- The 'Maybe' is evaluated to WHNF. +updateRWithKey :: (Build1 -> a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateRWithKey = updateRWithKey1 + + + +{-# INLINE takeL #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Take values for which keys are smaller than (or equal to) the given one. +takeL :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +takeL = takeL1 + +{-# INLINE takeR #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Take values for which keys are greater than (or equal to) the given one. +takeR :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +takeR = takeR1 + + + +{-# INLINE splitL #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Split1 the tree into two, such that +-- values with keys smaller than (or equal to) the given one are on the left, +-- and the rest are on the right. +splitL :: Openness -> Feed1 -> Radix1Tree a -> Split1 a a +splitL = splitL1 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +lookupMin :: Radix1Tree a -> Maybe a +lookupMin = lookupMin1 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +lookupMinWithKey :: Radix1Tree a -> Maybe (Lookup1 a) +lookupMinWithKey = lookupMinWithKey1 + +-- | \(\mathcal{O}(k)\). +-- Delete a value at the leftmost key in the tree. +deleteMin :: Radix1Tree a -> Radix1Tree a +deleteMin = deleteMin1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +adjustMin :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMin = adjustMin1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +adjustMinWithKey :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMinWithKey = adjustMinWithKey1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMin' :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMin' = adjustMin1' + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMinWithKey' :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMinWithKey' = adjustMinWithKey1' + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +updateMin :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMin = updateMin1 + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +updateMinWithKey :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMinWithKey = updateMinWithKey1 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the leftmost value and return it alongside the tree without it. +minView :: Radix1Tree a -> Maybe (ViewL1 a) +minView = minView1 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +lookupMax :: Radix1Tree a -> Maybe a +lookupMax = lookupMax1 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +lookupMaxWithKey :: Radix1Tree a -> Maybe (Lookup1 a) +lookupMaxWithKey = lookupMaxWithKey1 + +-- | \(\mathcal{O}(k)\). +-- Delete a value at the rightmost key in the tree. +deleteMax :: Radix1Tree a -> Radix1Tree a +deleteMax = deleteMax1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +adjustMax :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMax = adjustMax1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +adjustMaxWithKey :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMaxWithKey = adjustMaxWithKey1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMax' :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMax' = adjustMax1' + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMaxWithKey' :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMaxWithKey' = adjustMaxWithKey1' + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +updateMax :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMax = updateMax1 + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +updateMaxWithKey :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMaxWithKey = updateMaxWithKey1 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the rightmost value and return it alongside the tree without it. +maxView :: Radix1Tree a -> Maybe (ViewR1 a) +maxView = maxView1 + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Unbiased union of two trees. +union :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +union = union1 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Left-biased union of two trees. +unionL :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionL = unionL1 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Union of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +unionWith' :: (a -> a -> a) -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionWith' = unionWith1' + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Union of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +unionWithKey' :: (Build1 -> a -> a -> a) -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionWithKey' = unionWithKey1' + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees. +difference :: Radix1Tree a -> Radix1Tree b -> Radix1Tree a +difference = difference1 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees with a combining function. +-- +-- The 'Maybe' is evaluated to WHNF. +differenceWith + :: (a -> b -> Maybe a) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree a +differenceWith = differenceWith1 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees with a combining function. +-- +-- The 'Maybe' is evaluated to WHNF. +differenceWithKey + :: (Build1 -> a -> b -> Maybe a) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree a +differenceWithKey = differenceWithKey1 + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Compare two trees with respect to set inclusion, +-- using the given equality function for intersecting keys. +-- If any intersecting keys hold unequal values, the trees are 'Incomparable'. +compare :: (a -> b -> Bool) -> Radix1Tree a -> Radix1Tree b -> PartialOrdering +compare = compare1 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Determine whether two trees' key sets are disjoint. +disjoint :: Radix1Tree a -> Radix1Tree b -> Bool +disjoint = disjoint1 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Unbiased intersection of two trees. +intersection :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +intersection = intersection1 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Left-biased intersection of two trees. +intersectionL :: Radix1Tree a -> Radix1Tree b -> Radix1Tree a +intersectionL = intersectionL1 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Intersection of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +intersectionWith' :: (a -> b -> c) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c +intersectionWith' = intersectionWith1' + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Intersection of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +intersectionWithKey' :: (Build1 -> a -> b -> c) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c +intersectionWithKey' = intersectionWithKey1' diff --git a/src/Data/Radix1Tree/Word8/Strict/Debug.hs b/src/Data/Radix1Tree/Word8/Strict/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Strict/Debug.hs @@ -0,0 +1,30 @@ +{-| + Safe functions for datatype introspection. + -} + +module Data.Radix1Tree.Word8.Strict.Debug + ( -- * Show + showsTree + + -- * Validate + , Validity (..) + , Reason (..) + , validate + ) where + +import Data.RadixNTree.Word8.Strict (Radix1Tree) +import Data.RadixNTree.Word8.Strict.Debug + + + +-- | \(\mathcal{O}(n)\). +-- Shows the internal structure of the tree. +showsTree :: (a -> ShowS) -> Radix1Tree a -> ShowS +showsTree = showsTree1 + + + +-- | \(\mathcal{O}(n)\). +-- Checks whether the tree is well-formed. +validate :: Radix1Tree a -> Validity +validate = validate1 diff --git a/src/Data/Radix1Tree/Word8/Strict/TH.hs b/src/Data/Radix1Tree/Word8/Strict/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Strict/TH.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{-| + Template Haskell helper functions. + -} + +module Data.Radix1Tree.Word8.Strict.TH + ( sequenceCode + ) where + +import Data.RadixNTree.Word8.Strict.TH + +import Language.Haskell.TH.Syntax + + + +-- | \(\mathcal{O}(n)\). +-- Evaluate a tree of typed expressions. +sequenceCode :: Quote m => Radix1Tree (Code m a) -> Code m (Radix1Tree a) +sequenceCode = sequenceCode1 diff --git a/src/Data/Radix1Tree/Word8/Strict/Unsafe.hs b/src/Data/Radix1Tree/Word8/Strict/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Radix1Tree/Word8/Strict/Unsafe.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE UnboxedTuples #-} + +{-# OPTIONS_HADDOCK not-home #-} + +{-| + Data structure internals, helper operations and unsafe functions. + -} + +module Data.Radix1Tree.Word8.Strict.Unsafe + ( Radix1Tree (..) + + -- * Bit operations + , Prefix + , Key + + -- | === Compare + , beyond + , upper + , lower + + -- | === Create + , Mask + , zeroBit + , mask + , branchingBit + + -- * Exceptions + , MalformedTree (..) + + -- * Edges + -- ** Lookup + , Lookup1 (..) + + -- | === Min + , unsafeLookupMin + , unsafeLookupMinWithKey + + -- | === Max + , unsafeLookupMax + , unsafeLookupMaxWithKey + + -- ** Map + -- | === Min + , unsafeAdjustMin + , unsafeAdjustMin' + , unsafeAdjustMinWithKey + , unsafeAdjustMinWithKey' + + -- | === Max + , unsafeAdjustMax + , unsafeAdjustMax' + , unsafeAdjustMaxWithKey + , unsafeAdjustMaxWithKey' + + -- ** Delete + , unsafeDeleteMin + , unsafeDeleteMax + + -- ** Update + -- | === Min + , unsafeUpdateMin + , unsafeUpdateMinWithKey + + -- | === Max + , unsafeUpdateMax + , unsafeUpdateMaxWithKey + + -- ** View + -- | === Min + , ViewL1 (..) + , unsafeMinView + + -- | === Max + , ViewR1 (..) + , unsafeMaxView + + -- * Full-tree + -- ** Merge + , merge + ) where + +import Data.RadixNTree.Word8.Key +import Data.RadixNTree.Word8.Common +import Data.RadixNTree.Word8.Strict +import Radix.Exception +import Radix.Word.Foundation + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMin :: Radix1Tree a -> (# a #) +unsafeLookupMin = unsafeLookupMin1 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMinWithKey :: Radix1Tree a -> Lookup1 a +unsafeLookupMinWithKey = unsafeLookupMinWithKey1 + +-- | \(\mathcal{O}(k)\). +-- Delete a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeDeleteMin :: Radix1Tree a -> Radix1Tree a +unsafeDeleteMin = unsafeDeleteMin1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMin :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMin = unsafeAdjustMin1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMinWithKey :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMinWithKey = unsafeAdjustMinWithKey1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- New value is evaluated to WHNF. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMin' :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMin' = unsafeAdjustMin1' + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- New value is evaluated to WHNF. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMinWithKey' :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMinWithKey' = unsafeAdjustMinWithKey1' + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +unsafeUpdateMin :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMin = unsafeUpdateMin1 + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +unsafeUpdateMinWithKey :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMinWithKey = unsafeUpdateMinWithKey1 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the leftmost value and return it alongside the tree without it. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeMinView :: Radix1Tree a -> ViewL1 a +unsafeMinView = unsafeMinView1 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMax :: Radix1Tree a -> (# a #) +unsafeLookupMax = unsafeLookupMax1 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeLookupMaxWithKey :: Radix1Tree a -> Lookup1 a +unsafeLookupMaxWithKey = unsafeLookupMaxWithKey1 + +-- | \(\mathcal{O}(k)\). +-- Delete a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeDeleteMax :: Radix1Tree a -> Radix1Tree a +unsafeDeleteMax = unsafeDeleteMax1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMax :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMax = unsafeAdjustMax1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMaxWithKey :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMaxWithKey = unsafeAdjustMaxWithKey1 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- New value is evaluated to WHNF. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMax' :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMax' = unsafeAdjustMax1' + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- New value is evaluated to WHNF. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeAdjustMaxWithKey' :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMaxWithKey' = unsafeAdjustMaxWithKey1' + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +unsafeUpdateMax :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMax = unsafeUpdateMax1 + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +unsafeUpdateMaxWithKey :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMaxWithKey = unsafeUpdateMaxWithKey1 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the rightmost value and return it alongside the tree without it. +-- +-- Throws 'MalformedTree' if the tree is empty. +unsafeMaxView :: Radix1Tree a -> ViewR1 a +unsafeMaxView = unsafeMaxView1 + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- General merge of two trees. +-- +-- Resulting 'Maybe's and 'Radix1Tree's in argument functions are evaluated to WHNF. +-- +-- This functions inlines when all argument functions are provided. +{-# INLINE merge #-} +merge + :: (Build1 -> a -> b -> Maybe c) -- ^ Single value collision + -> (Build1 -> a -> Maybe c) -- ^ Single left value + -> (Build -> Radix1Tree a -> Radix1Tree c) -- ^ Left subtree + -> (Build1 -> b -> Maybe c) -- ^ Single right value + -> (Build -> Radix1Tree b -> Radix1Tree c) -- ^ Right subtree + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +merge = merge1 diff --git a/src/Data/RadixNTree/Word8/Common.hs b/src/Data/RadixNTree/Word8/Common.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Common.hs @@ -0,0 +1,25 @@ +module Data.RadixNTree.Word8.Common + ( Lookup (..) + , Lookup1 (..) + + , Openness (..) + ) where + +import Data.RadixNTree.Word8.Key + + + +-- | Key together with the value. +data Lookup a = Lookup !Build a + deriving Show + +-- | Key together with the value. +data Lookup1 a = Lookup1 !Build1 a + deriving Show + + + +-- | Whether the endpoint itself is included in the interval. +data Openness = Open -- ^ Excluding the point. + | Closed -- ^ Including the point. + deriving Show diff --git a/src/Data/RadixNTree/Word8/Conversion.hs b/src/Data/RadixNTree/Word8/Conversion.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Conversion.hs @@ -0,0 +1,38 @@ +module Data.RadixNTree.Word8.Conversion + ( Lazy.LazyRadixTree + , Lazy.LazyRadix1Tree + , toLazy0 + , toLazy1 + + , Strict.StrictRadixTree + , Strict.StrictRadix1Tree + , toStrict0 + , toStrict1 + ) where + +import qualified Data.RadixNTree.Word8.Lazy as Lazy +import qualified Data.RadixNTree.Word8.Strict as Strict + + + +toLazy0 :: Strict.StrictRadixTree a -> Lazy.LazyRadixTree a +toLazy0 (Strict.RadixTree mx t) = Lazy.RadixTree mx (toLazy1 t) + +toLazy1 :: Strict.StrictRadix1Tree a -> Lazy.LazyRadix1Tree a +toLazy1 t = + case t of + Strict.Bin p l r -> Lazy.Bin p (toLazy1 l) (toLazy1 r) + Strict.Tip arr mx dx -> Lazy.Tip arr mx (toLazy1 dx) + Strict.Nil -> Lazy.Nil + + + +toStrict0 :: Lazy.LazyRadixTree a -> Strict.StrictRadixTree a +toStrict0 (Lazy.RadixTree mx t) = Strict.RadixTree mx (toStrict1 t) + +toStrict1 :: Lazy.LazyRadix1Tree a -> Strict.StrictRadix1Tree a +toStrict1 t = + case t of + Lazy.Bin p l r -> Strict.Bin p (toStrict1 l) (toStrict1 r) + Lazy.Tip arr mx dx -> Strict.Tip arr mx (toStrict1 dx) + Lazy.Nil -> Strict.Nil diff --git a/src/Data/RadixNTree/Word8/Debug.hs b/src/Data/RadixNTree/Word8/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Debug.hs @@ -0,0 +1,29 @@ +module Data.RadixNTree.Word8.Debug + ( Validity (..) + , Reason (..) + ) where + +import Data.RadixNTree.Word8.Key +import Radix.Word8.Foundation + + + +-- | Whether the tree is well-formed. +data Validity = Valid + | Invalid Build Reason + deriving Show + +-- | Reason for why the tree is considered malformed. +data Reason = -- | Prefix is @0@. + ZeroPrefix + -- | Prefix below diverges from the prefix above. + | PrefixBelow Prefix Prefix + -- | Key diverges the prefix above. + | KeyBelow Prefix Key + -- | One of the branches is empty. + | MalformedBin Prefix + -- | Empty 'Data.Array.Byte.ByteArray'. + | EmptyByteArray + -- | @Tip@ stores no value and is not followed by a @Bin@. + | UncompressedTip + deriving Show diff --git a/src/Data/RadixNTree/Word8/Key.hs b/src/Data/RadixNTree/Word8/Key.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Key.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE BangPatterns + , RankNTypes #-} + +module Data.RadixNTree.Word8.Key + ( Tsil (..) + , YtpmeNon (..) + , Build (..) + + , buildBytes0 + + , buildByteString0 + , buildShortByteString0 + + , unsafeBuildText0 + + , Build1 (..) + + , buildBytes1 + + , buildByteString1 + , buildShortByteString1 + + , unsafeBuildText1 + + , Feed (..) + , feedBytes0 + + , feedByteString0 + , feedShortByteString0 + , feedLazyByteString0 + + , feedText0 + , feedLazyText0 + + , Feed1 (..) + , feedBytes1 + + , unsafeFeedByteString1 + , unsafeFeedShortByteString1 + , unsafeFeedLazyByteString1 + + , unsafeFeedText1 + , unsafeFeedLazyText1 + ) where + +import Data.ByteArray.NonEmpty + +import Control.Monad.ST +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as Strict (ByteString (..), unsafeCreate) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy.Internal as LazyBS (ByteString (..)) +import Data.ByteString.Short.Internal (ShortByteString (..)) +import Data.ByteString.Unsafe +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Primitive.ByteArray +import qualified Data.Text.Array as Array +import qualified Data.Text.Internal as Strict (Text (..)) +import qualified Data.Text.Internal.Lazy as LazyText (Text (..)) +import qualified Data.Text.Lazy as Lazy (Text) +import Data.Word +import Foreign.Ptr + + + +-- | Snoc-list. +data Tsil a = Lin + | Snoc (Tsil a) a + +-- | Snoc-list with a guaranteed element at the back. +data YtpmeNon a = Tsil a :/ a + +-- | Key as stored in the radix tree. +newtype Build = Build + -- | List of memory chunks that constitute the key. + -- + -- The first chunk is at the bottom of the list. + (Tsil ByteArray) + +instance Show Build where + showsPrec d = showsPrec d . buildBytes0 + +-- | Non-empty key as stored in the radix tree. +newtype Build1 = Build1 + -- | List of memory chunks that constitute the key. + -- + -- The first chunk is at the bottom of the list. + (YtpmeNon ByteArray) + +instance Show Build1 where + showsPrec d xs = let ~(y :| ys) = buildBytes1 xs + in showsPrec d (y:ys) + +buildBytes0 :: Build -> [Word8] +buildBytes0 (Build xs) = go [] xs + where + go acc as = + case as of + Snoc bs a -> go (Data.ByteArray.NonEmpty.toList a <> acc) bs + Lin -> acc + +buildBytes1 :: Build1 -> NonEmpty Word8 +buildBytes1 (Build1 (xs :/ x)) = go (toNonEmpty x) xs + where + go acc as = + case as of + Snoc bs a -> go (toNonEmpty a <> acc) bs + Lin -> acc + + + +sizeofBuild0 :: Build -> Int +sizeofBuild0 (Build xs) = go xs + where + go as = + case as of + Snoc bs arr -> sizeofByteArray arr + go bs + Lin -> 0 + +sizeofBuild1 :: Build1 -> Int +sizeofBuild1 (Build1 (xs :/ arr)) = sizeofByteArray arr + sizeofBuild0 (Build xs) + +writePtr :: Ptr Word8 -> Int -> Build -> IO () +writePtr ptr off0 (Build xs) = go off0 xs + where + go off as = + case as of + Snoc bs arr -> do + let off' = off - sizeofByteArray arr + copyByteArrayToAddr (plusPtr ptr off') arr 0 (sizeofByteArray arr) + go off' bs + + Lin -> pure () + +writePtr1 :: Ptr Word8 -> Int -> Build1 -> IO () +writePtr1 ptr off (Build1 (xs :/ arr)) = do + let off' = off - sizeofByteArray arr + copyByteArrayToAddr (plusPtr ptr off') arr 0 (sizeofByteArray arr) + writePtr ptr off' (Build xs) + + + +buildByteString0 :: Build -> Strict.ByteString +buildByteString0 xs = + let len = sizeofBuild0 xs + in Strict.unsafeCreate len (\ptr -> writePtr ptr len xs) + +buildByteString1 :: Build1 -> Strict.ByteString +buildByteString1 xs = + let len = sizeofBuild1 xs + in Strict.unsafeCreate len (\ptr -> writePtr1 ptr len xs) + + + +writeArr :: MutableByteArray s -> Int -> Build -> ST s () +writeArr marr off0 (Build xs) = go off0 xs + where + go off as = + case as of + Snoc bs arr -> do + let off' = off - sizeofByteArray arr + copyByteArray marr off' arr 0 (sizeofByteArray arr) + go off' bs + + Lin -> pure () + +writeArr1 :: MutableByteArray s -> Int -> Build1 -> ST s () +writeArr1 marr off (Build1 (xs :/ arr)) = do + let off' = off - sizeofByteArray arr + copyByteArray marr off' arr 0 (sizeofByteArray arr) + writeArr marr off' (Build xs) + + + +{-# INLINE buildShortByteString0 #-} +buildShortByteString0 :: Build -> ShortByteString +buildShortByteString0 xs = + runST $ do + let len = sizeofBuild0 xs + marr <- newByteArray len + writeArr marr len xs + ByteArray arr <- unsafeFreezeByteArray marr + pure $ SBS arr + +{-# INLINE buildShortByteString1 #-} +buildShortByteString1 :: Build1 -> ShortByteString +buildShortByteString1 xs = + runST $ do + let len = sizeofBuild1 xs + marr <- newByteArray len + writeArr1 marr len xs + ByteArray arr <- unsafeFreezeByteArray marr + pure $ SBS arr + +{-# INLINE unsafeBuildText0 #-} +unsafeBuildText0 :: Build -> Strict.Text +unsafeBuildText0 xs = + runST $ do + let len = sizeofBuild0 xs + marr <- newByteArray len + writeArr marr len xs + ByteArray arr <- unsafeFreezeByteArray marr + pure $ Strict.Text (Array.ByteArray arr) 0 len + +{-# INLINE unsafeBuildText1 #-} +unsafeBuildText1 :: Build1 -> Strict.Text +unsafeBuildText1 xs = + runST $ do + let len = sizeofBuild1 xs + marr <- newByteArray len + writeArr1 marr len xs + ByteArray arr <- unsafeFreezeByteArray marr + pure $ Strict.Text (Array.ByteArray arr) 0 len + + + +-- | Key as a sequence of individual bytes. +newtype Feed = Feed + -- | @destroy@ part of the @destroy/unfoldr@ rule. + (forall a. (forall x. (x -> Step Word8 x) -> x -> a) -> a) + +{-# INLINE vomit #-} +vomit :: (x -> Step a x) -> x -> [a] +vomit step = go + where + go s = + case step s of + More w ws -> w : go ws + Done -> [] + +instance Show Feed where + showsPrec d (Feed f) = showsPrec d $ f vomit + +noFeed :: Feed +noFeed = Feed $ \f -> f (\_ -> Done) () + +{-# INLINE feedBytes0 #-} +feedBytes0 :: [Word8] -> Feed +feedBytes0 ws0 = Feed $ \f -> f go ws0 + where + go (w:ws) = More w ws + go [] = Done + + + +-- | Key as a non-empty sequence of individual bytes. +data Feed1 = Feed1 + -- | First byte of the key. + {-# UNPACK #-} !Word8 + + -- | @destroy@ part of the @destroy/unfoldr@ rule. + (forall a. (forall x. (x -> Step Word8 x) -> x -> a) -> a) + +instance Show Feed1 where + showsPrec d (Feed1 w0 f) = showsPrec d $ w0 :| f vomit + +{-# INLINE feedBytes1 #-} +feedBytes1 :: NonEmpty Word8 -> Feed1 +feedBytes1 (w0 :| ws) = + let Feed f = feedBytes0 ws + in Feed1 w0 f + + + + +stepByteString :: Strict.ByteString -> Int -> Step Word8 Int +stepByteString bs = go + where + go n = + if n >= BS.length bs + then Done + else let !n' = n + 1 + in More (unsafeIndex bs n) n' + +{-# INLINE feedByteString0 #-} +feedByteString0 :: Strict.ByteString -> Feed +feedByteString0 bs = Feed $ \f -> f (stepByteString bs) 0 + +{-# INLINE unsafeFeedByteString1 #-} +unsafeFeedByteString1 :: Strict.ByteString -> Feed1 +unsafeFeedByteString1 bs = Feed1 (unsafeIndex bs 0) (\f -> f (stepByteString bs) 1) + + + +stepByteArray :: ByteArray -> Int -> Int -> Step Word8 Int +stepByteArray arr len = go + where + go n = + if n >= len + then Done + else let !n' = n + 1 + in More (indexByteArray arr n) n' + +{-# INLINE feedShortByteString0 #-} +feedShortByteString0 :: ShortByteString -> Feed +feedShortByteString0 (SBS arr) = + Feed $ \f -> + f (stepByteArray (ByteArray arr) $ sizeofByteArray (ByteArray arr)) 0 + +{-# INLINE unsafeFeedShortByteString1 #-} +unsafeFeedShortByteString1 :: ShortByteString -> Feed1 +unsafeFeedShortByteString1 (SBS arr) = + Feed1 (indexByteArray (ByteArray arr) 0) $ \f -> + f (stepByteArray (ByteArray arr) $ sizeofByteArray (ByteArray arr)) 1 + + + +{-# INLINE feedText0 #-} +feedText0 :: Strict.Text -> Feed +feedText0 (Strict.Text (Array.ByteArray arr) n len) = + Feed $ \f -> + f (stepByteArray (ByteArray arr) len) n + +{-# INLINE unsafeFeedText1 #-} +unsafeFeedText1 :: Strict.Text -> Feed1 +unsafeFeedText1 (Strict.Text (Array.ByteArray arr) n len) = + Feed1 (indexByteArray (ByteArray arr) n) $ \f -> + let !n' = n + 1 + in f (stepByteArray (ByteArray arr) len) n' + + + +data CarryBS = CarryBS Int Strict.ByteString Lazy.ByteString + +{-# INLINE stepLazyByteString #-} +stepLazyByteString :: CarryBS -> Step Word8 CarryBS +stepLazyByteString (CarryBS n bs lbs) = + if n >= BS.length bs + then case lbs of + LazyBS.Chunk bs' lbs' -> stepLazyByteString (CarryBS 0 bs' lbs') + LazyBS.Empty -> Done + + else let !n' = n + 1 + in More (unsafeIndex bs n) (CarryBS n' bs lbs) + +{-# INLINE feedLazyByteString0 #-} +feedLazyByteString0 :: Lazy.ByteString -> Feed +feedLazyByteString0 b = + case b of + LazyBS.Empty -> noFeed + LazyBS.Chunk bs lbs -> Feed $ \f -> f stepLazyByteString (CarryBS 0 bs lbs) + +{-# INLINE unsafeFeedLazyByteString1 #-} +unsafeFeedLazyByteString1 :: Strict.ByteString -> Lazy.ByteString -> Feed1 +unsafeFeedLazyByteString1 bs lbs = + Feed1 (unsafeIndex bs 0) $ \f -> + f stepLazyByteString (CarryBS 1 bs lbs) + + + +data CarryTxt = CarryTxt Int Int ByteArray Lazy.Text + +{-# INLINE stepLazyText #-} +stepLazyText :: CarryTxt -> Step Word8 CarryTxt +stepLazyText (CarryTxt n len arr t) = + if n >= len + then case t of + LazyText.Chunk (Strict.Text (Array.ByteArray arr') n' len') t' -> + stepLazyText (CarryTxt n' len' (ByteArray arr') t') + + LazyText.Empty -> Done + + else let !n' = n + 1 + in More (indexByteArray arr n) (CarryTxt n' len arr t) + +{-# INLINE feedLazyText0 #-} +feedLazyText0 :: Lazy.Text -> Feed +feedLazyText0 t = + case t of + LazyText.Empty -> noFeed + LazyText.Chunk (Strict.Text (Array.ByteArray arr) n len) ltxt -> + Feed $ \f -> f stepLazyText (CarryTxt n len (ByteArray arr) ltxt) + +{-# INLINE unsafeFeedLazyText1 #-} +unsafeFeedLazyText1 :: Strict.Text -> Lazy.Text -> Feed1 +unsafeFeedLazyText1 (Strict.Text (Array.ByteArray arr) n len) ltxt = + Feed1 (indexByteArray (ByteArray arr) n) $ \f -> + let !n' = n + 1 + in f stepLazyText (CarryTxt n' len (ByteArray arr) ltxt) diff --git a/src/Data/RadixNTree/Word8/Lazy.hs b/src/Data/RadixNTree/Word8/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Lazy.hs @@ -0,0 +1,5076 @@ +{-# LANGUAGE BangPatterns + , GADTs + , RankNTypes + , ScopedTypeVariables + , UnboxedTuples #-} + +module Data.RadixNTree.Word8.Lazy + ( LazyRadixTree + , RadixTree (..) + + , LazyRadix1Tree + , Radix1Tree (..) + + , empty0 + , empty1 + + , singleton0 + , singleton1 + + , map0 + , mapWithKey0 + + , map1 + , mapWithKey1 + + , foldl0 + , foldl0' + , foldlWithKey0 + , foldlWithKey0' + + , Data.RadixNTree.Word8.Lazy.foldl1 + , foldl1' + , foldlWithKey1 + , foldlWithKey1' + + , foldr0 + , foldr0' + , foldrWithKey0 + , foldrWithKey0' + + , Data.RadixNTree.Word8.Lazy.foldr1 + , foldr1' + , foldrWithKey1 + , foldrWithKey1' + + , foldMap0 + , foldMapWithKey0 + + , foldMap1 + , foldMapWithKey1 + + , traverse0 + , traverseWithKey0 + + , traverse1 + , traverseWithKey1 + + , null0 + , null1 + + , size0 + , size1 + + , lookup0 + , find0 + , member0 + , subtree0 + , prefix0 + + , lookup1 + , find1 + , member1 + , subtree1 + , prefix1 + + , Point (..) + , Cursor (..) + , stop + + , Location (..) + , locate + + , cursor0 + , move0 + + , cursor1 + , move1 + + , lookupL0 + , lookupL1 + + , lookupR0 + , lookupR1 + + , adjustL0 + , adjustLWithKey0 + + , adjustL1 + , adjustLWithKey1 + + , adjustR0 + , adjustRWithKey0 + + , adjustR1 + , adjustRWithKey1 + + , updateL0 + , updateLWithKey0 + + , updateL1 + , updateLWithKey1 + + , updateR0 + , updateRWithKey0 + + , updateR1 + , updateRWithKey1 + + , takeL0 + , takeL1 + + , takeR0 + , takeR1 + + , union0 + , union1 + + , unionL0 + , unionL1 + + , unionWith0 + , unionWith1 + + , unionWithKey0 + , unionWithKey1 + + , difference0 + , difference1 + + , differenceWith0 + , differenceWith1 + + , differenceWithKey0 + , differenceWithKey1 + + , compare0 + , Data.RadixNTree.Word8.Lazy.compare1 + + , disjoint0 + , disjoint1 + + , intersection0 + , intersection1 + + , intersectionL0 + , intersectionL1 + + , intersectionWith0 + , intersectionWith1 + + , intersectionWithKey0 + , intersectionWithKey1 + + , merge0 + , merge1 + + , insert0 + , insert1 + + , insertWith0 + , insertWith1 + + , adjust0 + , adjust1 + + , delete0 + , delete1 + + , prune0 + , prune1 + + , update0 + , update1 + + , alter0 + , alter1 + + , shape0 + , shape1 + + , splitL0 + , splitL1 + + , splitLookup0 + , splitLookup1 + + , filter0 + , filterWithKey0 + + , filter1 + , filterWithKey1 + + , mapMaybe0 + , mapMaybeWithKey0 + + , mapMaybe1 + , mapMaybeWithKey1 + + , partition0 + , partitionWithKey0 + + , partition1 + , partitionWithKey1 + + , mapEither0 + , mapEitherWithKey0 + + , mapEither1 + , mapEitherWithKey1 + + , lookupMin0 + , lookupMin1 + , unsafeLookupMin1 + + , lookupMinWithKey0 + , lookupMinWithKey1 + , unsafeLookupMinWithKey1 + + , lookupMax0 + , lookupMax1 + , unsafeLookupMax1 + + , lookupMaxWithKey0 + , lookupMaxWithKey1 + , unsafeLookupMaxWithKey1 + + , deleteMin0 + , deleteMin1 + , unsafeDeleteMin1 + + , deleteMax0 + , deleteMax1 + , unsafeDeleteMax1 + + , adjustMin0 + , adjustMin1 + , unsafeAdjustMin1 + + , adjustMinWithKey0 + , adjustMinWithKey1 + , unsafeAdjustMinWithKey1 + + , adjustMax0 + , adjustMax1 + , unsafeAdjustMax1 + + , adjustMaxWithKey0 + , adjustMaxWithKey1 + , unsafeAdjustMaxWithKey1 + + , updateMin0 + , updateMin1 + , unsafeUpdateMin1 + + , updateMinWithKey0 + , updateMinWithKey1 + , unsafeUpdateMinWithKey1 + + , updateMax0 + , updateMax1 + , unsafeUpdateMax1 + + , updateMaxWithKey0 + , updateMaxWithKey1 + , unsafeUpdateMaxWithKey1 + + , ViewL (..) + , ViewL1 (..) + , minView0 + , minView1 + , unsafeMinView1 + + , ViewR (..) + , ViewR1 (..) + , maxView0 + , maxView1 + , unsafeMaxView1 + ) where + +import Data.ByteArray.NonEmpty +import Data.RadixNTree.Word8.Common +import Data.RadixNTree.Word8.Key +import Radix.Common +import Radix.Exception +import Radix.Word8.Common +import Radix.Word8.Foundation + +import Control.Applicative +import Control.Exception (throw) +import Control.DeepSeq +import Data.Bits +import Data.Foldable +import Data.Functor.Classes +import Data.Primitive.ByteArray +import Data.Word +import Text.Show + + + +-- | Convenience type synonym. +type LazyRadixTree = RadixTree + +-- | Spine-strict radix tree with byte sequences as keys. +data RadixTree a = RadixTree + {-# UNPACK #-} !(Maybe a) -- ^ Value at the empty byte sequence key. + (Radix1Tree a) + +instance Show a => Show (RadixTree a) where + showsPrec = liftShowsPrec showsPrec showList + +instance Show1 RadixTree where + liftShowsPrec showsPrec_ showList_ d t = + showParen (d > 10) $ + showListWith (liftShowsPrec showsPrec_ showList_ 0) $ + foldrWithKey0 (\k a -> (:) (k, a)) [] t + +instance Eq a => Eq (RadixTree a) where + (==) = liftEq (==) + +instance Eq1 RadixTree where + liftEq eq (RadixTree mx l) (RadixTree my r) = liftEq eq mx my && liftEq eq l r + +-- | Uses 'Data.RadixTree.Word8.Lazy.map'. +instance Functor RadixTree where + fmap = map0 + +instance Foldable RadixTree where + foldl = foldl0 + foldr = foldr0 + foldMap = foldMap0 + + foldl' = foldl0' + foldr' = foldr0' + + null = null0 + + length = size0 + +instance Traversable RadixTree where + traverse = traverse0 + + +instance NFData a => NFData (RadixTree a) where + rnf = liftRnf rnf + +instance NFData1 RadixTree where + liftRnf nf (RadixTree mx t) = liftRnf nf mx `seq` liftRnf nf t + + + +-- | Convenience type synonym. +type LazyRadix1Tree = Radix1Tree + +-- | Spine-strict radix tree with non-empty byte sequences as keys. +data Radix1Tree a = Bin + {-# UNPACK #-} !Prefix + (Radix1Tree a) -- ^ Masked bit is @0@. Invariant: not 'Nil'. + (Radix1Tree a) -- ^ Masked bit is @1@. Invariant: not 'Nil'. + + | Tip + {-# UNPACK #-} !ByteArray -- ^ Invariant: non-empty. + {-# UNPACK #-} !(Maybe a) -- ^ Invariant: can only be 'Nothing' when + -- the tree below is 'Bin'. + (Radix1Tree a) + + | Nil + +instance Show a => Show (Radix1Tree a) where + showsPrec = liftShowsPrec showsPrec showList + +instance Show1 Radix1Tree where + liftShowsPrec showsPrec_ showList_ d t = + showParen (d > 10) $ + showListWith (liftShowsPrec showsPrec_ showList_ 0) $ + foldrWithKey1 (\k a -> (:) (k, a)) [] t + +instance Eq a => Eq (Radix1Tree a) where + (==) = liftEq (==) + +instance Eq1 Radix1Tree where + liftEq eq = go + where + go l r = + case l of + Bin p xl xr -> + case r of + Bin q yl yr -> p == q && go xl yl && go xr yr + _ -> False + + Tip arr mx dx -> + case r of + Tip brr my dy -> arr == brr && liftEq eq mx my && go dx dy + _ -> False + + Nil -> + case r of + Nil -> True + _ -> False + +-- | Uses 'Data.Radix1Tree.Word8.Lazy.map'. +instance Functor Radix1Tree where + fmap = map1 + +instance Foldable Radix1Tree where + foldl = Data.RadixNTree.Word8.Lazy.foldl1 + foldr = Data.RadixNTree.Word8.Lazy.foldr1 + foldMap = foldMap1 + + foldl' = foldl1' + foldr' = foldr1' + + null = null1 + + length = size1 + +instance Traversable Radix1Tree where + traverse = traverse1 + + +instance NFData a => NFData (Radix1Tree a) where + rnf = liftRnf rnf + +instance NFData1 Radix1Tree where + liftRnf nf = go + where + go t = + case t of + Bin _ l r -> go l `seq` go r + Tip _ mx dx -> liftRnf nf mx `seq` go dx + Nil -> () + + + + +{-# INLINE join #-} +-- | Knowing that the prefices of two trees disagree, construct a 'Bin'. +join :: Prefix -> Radix1Tree a -> Prefix -> Radix1Tree a -> Radix1Tree a +join p0 t0 p1 t1 = + let m = branchingBit p0 p1 + + p = mask p0 m .|. m + + in if zeroBit p0 m + then Bin p t0 t1 + else Bin p t1 t0 + +{-# INLINE safeJoin #-} +safeJoin :: Prefix -> Radix1Tree a -> Prefix -> Radix1Tree a -> Radix1Tree a +safeJoin _ Nil _ t1 = t1 +safeJoin _ t0 _ Nil = t0 +safeJoin p0 t0 p1 t1 = join p0 t0 p1 t1 + +{-# INLINE retip #-} +-- | Based on the altered entry and/or downward state, fuse or remove the 'Tip' as needed. +retip :: ByteArray -> Maybe a -> Radix1Tree a -> Radix1Tree a +retip arr mx dx = + case mx of + Just _ -> Tip arr mx dx + Nothing -> + case dx of + Bin _ _ _ -> Tip arr mx dx + Tip brr my dy -> Tip (appendByteArray arr brr) my dy + Nil -> Nil + +{-# INLINE dropTrim #-} +dropTrim :: Int -> ByteArray -> Maybe a -> Radix1Tree a -> Radix1Tree a +dropTrim n arr mx dx = + case mx of + Just _ -> Tip (dropByteArray n arr) mx dx + Nothing -> + case dx of + Bin _ _ _ -> Tip (dropByteArray n arr) mx dx + Tip brr my dy -> Tip (dropAppendByteArray n arr brr) my dy + Nil -> Nil + + +{-# INLINE rebin #-} +rebin :: Prefix -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +rebin p l r = + case l of + Nil -> r + _ -> case r of + Nil -> l + _ -> Bin p l r + +{-# INLINE rebinL #-} +rebinL :: Prefix -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +rebinL p l r = + case l of + Nil -> r + _ -> Bin p l r + +{-# INLINE rebinR #-} +rebinR :: Prefix -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +rebinR p l r = + case r of + Nil -> l + _ -> Bin p l r + + + +empty0 :: RadixTree a +empty0 = RadixTree Nothing Nil + +empty1 :: Radix1Tree a +empty1 = Nil + + + +{-# INLINE singleton0 #-} +singleton0 :: Feed -> a -> RadixTree a +singleton0 (Feed feed) = \a -> + feed $ \step s -> + case step s of + More w z -> RadixTree Nothing $ singleton1 (Feed1 w (\g -> g step z)) a + Done -> RadixTree (Just a) Nil + +{-# INLINE singleton1 #-} +singleton1 :: Feed1 -> a -> Radix1Tree a +singleton1 (Feed1 w feed) = \a -> feed $ \step s -> singleton_ step w s a + +{-# INLINE singleton_ #-} +-- | \(\mathcal{O}(1)\). Single element radix tree. +singleton_ :: (b -> Step Word8 b) -> Word8 -> b -> a -> Radix1Tree a +singleton_ step w s = \a -> Tip (fromStep step w s) (Just a) Nil + + + +null0 :: RadixTree a -> Bool +null0 (RadixTree Nothing t) = null1 t +null0 _ = False + +null1 :: Radix1Tree a -> Bool +null1 Nil = True +null1 _ = False + + + +size0 :: RadixTree a -> Int +size0 (RadixTree mx t) = + let !n = size1 t + in case mx of + Just _ -> n + 1 + Nothing -> n + +size1 :: Radix1Tree a -> Int +size1 = go 0 + where + go z t = + case t of + Bin _ l r -> let !n = go z l + in go n r + + Tip _ mx dx -> case mx of + Nothing -> go z dx + Just _ -> let !n = go z dx + in n + 1 + Nil -> z + + + +{-# INLINE fmap' #-} +fmap' :: (a -> b) -> Maybe a -> Maybe b +fmap' f (Just x) = Just $! f x +fmap' _ Nothing = Nothing + + + +map0 :: (a -> b) -> RadixTree a -> RadixTree b +map0 f (RadixTree mx t) = RadixTree (fmap f mx) $ map1 f t + +map1 :: (a -> b) -> Radix1Tree a -> Radix1Tree b +map1 f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) (go r) + Tip arr mx dx -> Tip arr (fmap f mx) (go dx) + Nil -> Nil + + + +mapWithKey0 :: (Build -> a -> b) -> RadixTree a -> RadixTree b +mapWithKey0 f (RadixTree mx t) = + RadixTree (f (Build Lin) <$> mx) $ + mapWithKey_ (\b arr -> f (Build $ Snoc b arr)) Lin t + +mapWithKey1 :: (Build1 -> a -> b) -> Radix1Tree a -> Radix1Tree b +mapWithKey1 f = mapWithKey_ (\b arr -> f (Build1 $ b :/ arr)) Lin + +{-# INLINE mapWithKey_ #-} +mapWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> b) -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b +mapWithKey_ f = go + where + go b t = + case t of + Bin p l r -> Bin p (go b l) (go b r) + Tip arr mx dx -> Tip arr (f b arr <$> mx) (go (Snoc b arr) dx) + Nil -> Nil + + + +foldl0 :: (b -> a -> b) -> b -> RadixTree a -> b +foldl0 f z (RadixTree mx t) = + let z' = case mx of + Just x -> f z x + Nothing -> z + + in Data.RadixNTree.Word8.Lazy.foldl1 f z' t + +foldl1 :: (b -> a -> b) -> b -> Radix1Tree a -> b +foldl1 f = go + where + go z t = + case t of + Bin _ l r -> go (go z l) r + + Tip _ mx dx -> let z' = case mx of + Just x -> f z x + Nothing -> z + + in go z' dx + + Nil -> z + + + +foldl0' :: (b -> a -> b) -> b -> RadixTree a -> b +foldl0' f z (RadixTree mx t) = + let !z' = case mx of + Just x -> f z x + Nothing -> z + + in Data.RadixNTree.Word8.Lazy.foldl1' f z' t + +foldl1' :: (b -> a -> b) -> b -> Radix1Tree a -> b +foldl1' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z l + in go z' r + + Tip _ mx dx -> let !z' = case mx of + Just x -> f z x + Nothing -> z + + in go z' dx + + Nil -> z + + + +foldlWithKey0 :: (b -> Build -> a -> b) -> b -> RadixTree a -> b +foldlWithKey0 f z (RadixTree mx t) = + let z' = case mx of + Just x -> f z (Build Lin) x + Nothing -> z + + in foldlWithKey_ (\z'' b arr -> f z'' (Build $ Snoc b arr)) z' t + +foldlWithKey1 :: (b -> Build1 -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey1 f = foldlWithKey_ (\z b arr -> f z (Build1 $ b :/ arr)) + +{-# INLINE foldlWithKey_ #-} +foldlWithKey_ :: (b -> Tsil ByteArray -> ByteArray -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey_ f = go Lin + where + go b z t = + case t of + Bin _ l r -> go b (go b z l) r + + Tip arr mx dx -> + case mx of + Nothing -> go (Snoc b arr) z dx + Just a -> go (Snoc b arr) (f z b arr a) dx + + Nil -> z + + + +foldlWithKey0' :: (b -> Build -> a -> b) -> b -> RadixTree a -> b +foldlWithKey0' f z (RadixTree mx t) = + let !z' = case mx of + Just x -> f z (Build Lin) x + Nothing -> z + + in foldlWithKey'_ (\z'' b arr -> f z'' (Build $ Snoc b arr)) z' t + +foldlWithKey1' :: (b -> Build1 -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey1' f = foldlWithKey'_ (\z b arr -> f z (Build1 $ b :/ arr)) + +{-# INLINE foldlWithKey'_ #-} +foldlWithKey'_ :: (b -> Tsil ByteArray -> ByteArray -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey'_ f = go Lin + where + go b !z t = + case t of + Bin _ l r -> let !z' = go b z l + in go b z' r + + Tip arr mx dx -> + case mx of + Nothing -> go (Snoc b arr) z dx + Just a -> let !z' = f z b arr a + in go (Snoc b arr) z' dx + + Nil -> z + + + +foldr0 :: (a -> b -> b) -> b -> RadixTree a -> b +foldr0 f z (RadixTree mx t) = + let z' = Data.RadixNTree.Word8.Lazy.foldr1 f z t + in case mx of + Just x -> f x z' + Nothing -> z' + +foldr1 :: (a -> b -> b) -> b -> Radix1Tree a -> b +foldr1 f = go + where + go z t = + case t of + Bin _ l r -> go (go z r) l + + Tip _ mx dx -> let z' = go z dx + in case mx of + Just x -> f x z' + Nothing -> z' + + Nil -> z + + + +foldr0' :: (a -> b -> b) -> b -> RadixTree a -> b +foldr0' f z (RadixTree mx t) = + let !z' = Data.RadixNTree.Word8.Lazy.foldr1' f z t + in case mx of + Just x -> f x z' + Nothing -> z' + +foldr1' :: (a -> b -> b) -> b -> Radix1Tree a -> b +foldr1' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z r + in go z' l + + Tip _ mx dx -> let !z' = go z dx + in case mx of + Just x -> f x z' + Nothing -> z' + + Nil -> z + + + +foldrWithKey0 :: (Build -> a -> b -> b) -> b -> RadixTree a -> b +foldrWithKey0 f z (RadixTree mx t) = + let z' = foldrWithKey_ (\b arr -> f (Build $ Snoc b arr)) z t + in case mx of + Just x -> f (Build Lin) x z' + Nothing -> z' + +foldrWithKey1 :: (Build1 -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey1 f = foldrWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE foldrWithKey_ #-} +foldrWithKey_ :: (Tsil ByteArray -> ByteArray -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey_ f = go Lin + where + go b z t = + case t of + Bin _ l r -> go b (go b z r) l + + Tip arr mx dx -> let z' = go (Snoc b arr) z dx + in case mx of + Just x -> f b arr x z' + Nothing -> z' + + Nil -> z + + + +foldrWithKey0' :: (Build -> a -> b -> b) -> b -> RadixTree a -> b +foldrWithKey0' f z (RadixTree mx t) = + let !z' = foldrWithKey'_ (\b arr -> f (Build $ Snoc b arr)) z t + in case mx of + Just x -> f (Build Lin) x z' + Nothing -> z' + +foldrWithKey1' :: (Build1 -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey1' f = foldrWithKey'_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE foldrWithKey'_ #-} +foldrWithKey'_ :: (Tsil ByteArray -> ByteArray -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey'_ f = go Lin + where + go b !z t = + case t of + Bin _ l r -> let !z' = go b z r + in go b z' l + + Tip arr mx dx -> let !z' = go (Snoc b arr) z dx + in case mx of + Just x -> f b arr x z' + Nothing -> z' + + Nil -> z + + + +foldMap0 :: Monoid m => (a -> m) -> RadixTree a -> m +foldMap0 f (RadixTree mx t) = + let m = foldMap1 f t + in case mx of + Just x -> f x <> m + Nothing -> m + +foldMap1 :: Monoid m => (a -> m) -> Radix1Tree a -> m +foldMap1 f = go + where + go t = + case t of + Bin _ l r -> go l <> go r + + Tip _ mx dx -> let m = go dx + in case mx of + Nothing -> m + Just a -> f a <> m + + Nil -> mempty + + + +foldMapWithKey0 :: Monoid m => (Build -> a -> m) -> RadixTree a -> m +foldMapWithKey0 f (RadixTree mx t) = + let m = foldMapWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + in case mx of + Just x -> f (Build Lin) x <> m + Nothing -> m + +foldMapWithKey1 :: Monoid m => (Build1 -> a -> m) -> Radix1Tree a -> m +foldMapWithKey1 f = foldMapWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE foldMapWithKey_ #-} +foldMapWithKey_ + :: Monoid m => (Tsil ByteArray -> ByteArray -> a -> m) -> Radix1Tree a -> m +foldMapWithKey_ f = go Lin + where + go b t = + case t of + Bin _ l r -> go b l <> go b r + + Tip arr mx dx -> + let m = go (Snoc b arr) dx + in case mx of + Nothing -> m + Just a -> f b arr a <> m + + Nil -> mempty + + + +traverse0 :: Applicative f => (a -> f b) -> RadixTree a -> f (RadixTree b) +traverse0 f (RadixTree mx t) = + let dy = traverse1 f t + in case mx of + Just x -> liftA2 RadixTree (Just <$> f x) dy + Nothing -> RadixTree Nothing <$> dy + +traverse1 :: Applicative f => (a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverse1 f = go + where + go t = + case t of + Bin p l r -> liftA2 (Bin p) (go l) (go r) + + Tip arr mx dx -> + case mx of + Nothing -> Tip arr Nothing <$> go dx + Just x -> liftA2 (Tip arr . Just) (f x) (go dx) + + Nil -> pure Nil + + + +traverseWithKey0 :: Applicative f => (Build -> a -> f b) -> RadixTree a -> f (RadixTree b) +traverseWithKey0 f (RadixTree mx t) = + let dy = traverseWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + in case mx of + Just x -> liftA2 RadixTree (Just <$> f (Build Lin) x) dy + Nothing -> RadixTree Nothing <$> dy + +traverseWithKey1 + :: Applicative f => (Build1 -> a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverseWithKey1 f = traverseWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE traverseWithKey_ #-} +traverseWithKey_ + :: Applicative f + => (Tsil ByteArray -> ByteArray -> a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverseWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> liftA2 (Bin p) (go b l) (go b r) + + Tip arr mx dx -> + let dy = go (Snoc b arr) dx + in case mx of + Nothing -> Tip arr Nothing <$> dy + Just a -> liftA2 (Tip arr . Just) (f b arr a) dy + + Nil -> pure Nil + + + +{-# INLINE lookup0 #-} +lookup0 :: Feed -> RadixTree a -> Maybe a +lookup0 (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> lookup_ step w z t + Done -> mx + +{-# INLINE lookup1 #-} +lookup1 :: Feed1 -> Radix1Tree a -> Maybe a +lookup1 (Feed1 w feed) = feed $ \step -> lookup_ step w + +{-# INLINE lookup_ #-} +lookup_ :: (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Maybe a +lookup_ step = go + where + go w s t = + case t of + Bin p l r -> + go w s $ if w < p + then l + else r + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + let n' = n + 1 + in if n' >= sizeofByteArray arr + then case step z of + More u z' -> go u z' dx + Done -> mx + + else case step z of + More u z' -> goarr u z' n' + Done -> Nothing + + | otherwise = Nothing + + Nil -> Nothing + + + +{-# INLINE find0 #-} +find0 :: a -> Feed -> RadixTree a -> a +find0 d (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> find_ d step w z t + Done -> case mx of + Just x -> x + Nothing -> d + +{-# INLINE find1 #-} +find1 :: a -> Feed1 -> Radix1Tree a -> a +find1 d (Feed1 w feed) = feed $ \step -> find_ d step w + +{-# INLINE find_ #-} +find_ :: a -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> a +find_ d step = go + where + go w s t = + case t of + Bin p l r -> + go w s $ if w < p + then l + else r + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + let n' = n + 1 + in if n' >= sizeofByteArray arr + then case step z of + More u z' -> go u z' dx + Done -> case mx of + Just x -> x + Nothing -> d + + else case step z of + More u z' -> goarr u z' n' + Done -> d + + | otherwise = d + + Nil -> d + + + +{-# INLINE member0 #-} +member0 :: Feed -> RadixTree a -> Bool +member0 (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> member_ step w z t + Done -> case mx of + Just _ -> True + Nothing -> False + +{-# INLINE member1 #-} +member1 :: Feed1 -> Radix1Tree a -> Bool +member1 (Feed1 w feed) = feed $ \step -> member_ step w + +{-# INLINE member_ #-} +member_ :: (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Bool +member_ step = go + where + go w s t = + case t of + Bin p l r -> + go w s $ if w < p + then l + else r + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + let n' = n + 1 + in if n' >= sizeofByteArray arr + then case step z of + More u z' -> go u z' dx + Done -> case mx of + Just _ -> True + Nothing -> False + + else case step z of + More u z' -> goarr u z' n' + Done -> False + + | otherwise = False + + Nil -> False + + + +{-# INLINE subtree0 #-} +subtree0 :: Feed -> RadixTree a -> RadixTree a +subtree0 (Feed feed) = \t0@(RadixTree _ t) -> + feed $ \step s -> + case step s of + More w z -> subtree_ step w z t + Done -> t0 + +{-# INLINE subtree1 #-} +subtree1 :: Feed1 -> Radix1Tree a -> RadixTree a +subtree1 (Feed1 w feed) = feed $ \step -> subtree_ step w + +{-# INLINE subtree_ #-} +subtree_ :: (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> RadixTree a +subtree_ step = go + where + go w s t = + case t of + Bin p l r -> + go w s $ if w < p + then l + else r + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> go u z' dx + Done -> RadixTree mx dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> let rest = dropTrim (n + 1) arr mx dx + in rest `seq` RadixTree Nothing rest + + | otherwise = RadixTree Nothing Nil + + Nil -> RadixTree Nothing Nil + + + +{-# INLINE prefix0 #-} +prefix0 :: Feed -> RadixTree a -> RadixTree a +prefix0 (Feed feed) = \t -> + feed $ \step s -> + case step s of + More w z -> RadixTree Nothing $ prefix_ step w z t + Done -> t + +{-# INLINE prefix1 #-} +prefix1 :: Feed1 -> RadixTree a -> Radix1Tree a +prefix1 (Feed1 w feed) = + feed $ \step -> prefix_ step w + +{-# INLINE prefix_ #-} +prefix_ :: (x -> Step Word8 x) -> Word8 -> x -> RadixTree a -> Radix1Tree a +prefix_ step = \w z (RadixTree mx t) -> + case mx of + Nothing -> + case t of + Bin _ _ _ -> Tip (fromStep step w z) Nothing t + Tip arr my dy -> Tip (fromStepAppend step w z arr) my dy + Nil -> Nil + + Just _ -> Tip (fromStep step w z) mx t + + + +-- | Current position in the tree. +data Point = -- | Above a node. + Seam + + -- | In the middle of a 'Tip'. + | Plane + {-# UNPACK #-} !Int -- ^ Always greater than @0@ and smaller than + -- the length of the 'ByteArray'. + {-# UNPACK #-} !ByteArray + +-- | A particular point in the tree. +data Cursor a = -- | This is effectively a 'Tip' where the 'ByteArray' is optional. + Cursor + {-# UNPACK #-} !Point + {-# UNPACK #-} !(Maybe a) + (Radix1Tree a) + +instance Show a => Show (Cursor a) where + showsPrec d c = + showParen (d > 10) $ + showString "Cursor " . showsPrec 11 (stop c) + +cursor0 :: RadixTree a -> Cursor a +cursor0 (RadixTree mx t) = Cursor Seam mx t + +cursor1 :: Radix1Tree a -> Cursor a +cursor1 = Cursor Seam Nothing + +{-# INLINE move0 #-} +move0 :: Feed -> Cursor a -> Cursor a +move0 (Feed feed) = \c -> + feed $ \step s -> + case step s of + More w z -> move_ step w z c + Done -> c + +{-# INLINE move1 #-} +move1 :: Feed1 -> Cursor a -> Cursor a +move1 (Feed1 w feed) = feed $ \step -> move_ step w + +{-# INLINE move_ #-} +move_ :: (x -> Step Word8 x) -> Word8 -> x -> Cursor a -> Cursor a +move_ step = \w s (Cursor point mx dx) -> + case point of + Seam -> go w s dx + Plane i arr -> goarr arr mx dx w s i + where + go w s t = + case t of + Bin p l r -> go w s $ if w < p + then l + else r + + Tip brr my dy -> goarr brr my dy w s 0 + + Nil -> Cursor Seam Nothing Nil + + goarr arr mx dx = goarr_ + where + goarr_ w s n + | w == indexByteArray arr n = + let !n' = n + 1 + in case step s of + More v z + | n' >= sizeofByteArray arr -> go v z dx + | otherwise -> goarr_ v z n' + + Done -> + let !point' + | n' >= sizeofByteArray arr = Seam + | otherwise = Plane n' arr + + in Cursor point' mx dx + + | otherwise = Cursor Seam Nothing Nil + +-- | \(\mathcal{O}(1)\). +-- Retrieve the value at which the cursor points. +stop :: Cursor a -> Maybe a +stop (Cursor point mx _) = + case point of + Seam -> mx + _ -> Nothing + +-- | \(\mathcal{O}(1)\). +-- Determine whether the cursor points to a point within the tree. +locate :: Cursor a -> Location +locate (Cursor _ Nothing Nil) = Outside +locate _ = Inside + + + +{-# INLINE lookupL0 #-} +lookupL0 :: Openness -> Feed -> RadixTree a -> Maybe (Lookup a) +lookupL0 openness (Feed feed) (RadixTree mx t) = + feed $ \step s -> + case step s of + More w z -> + let l = lookupL_ (\b arr -> Lookup (Build $ Snoc b arr)) openness step w z t + in case l of + Just _ -> l + Nothing -> + case mx of + Just x -> Just $ Lookup (Build Lin) x + Nothing -> Nothing + + _ -> + case openness of + Open -> Nothing + Closed -> case mx of + Just x -> Just $ Lookup (Build Lin) x + Nothing -> Nothing + +{-# INLINE lookupL1 #-} +lookupL1 :: Openness -> Feed1 -> Radix1Tree a -> Maybe (Lookup1 a) +lookupL1 openness (Feed1 w feed) = + feed $ \step -> lookupL_ (\b arr -> Lookup1 (Build1 (b :/ arr))) openness step w + +{-# INLINE lookupL_ #-} +lookupL_ + :: (Tsil ByteArray -> ByteArray -> a -> b) + -> Openness -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Maybe b +lookupL_ f openness step = go Lin Nothing + where + getMax b t = + let !(# b', arr, a #) = unsafeLookupMaxWithKey_ b t + in Just $! f b' arr a + + go b getL !w !s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go b getL w s l + else getL + + else if w <= upper p + then go b (getMax b l) w s r + else getMax b r + + Tip arr mx dx -> goarr w s 0 + where + getThis = f b arr `fmap'` mx + + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + let getL' = getThis <|> getL + in case step z of + More u z' -> go (Snoc b arr) getL' u z' dx + Done -> + case openness of + Open -> getL + Closed -> getL' + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> getL + + LT -> case dx of + Nil -> getThis + _ -> getMax (Snoc b arr) dx + + GT -> getL + + Nil -> getL + + + +{-# INLINE lookupR0 #-} +lookupR0 :: Openness -> Feed -> RadixTree a -> Maybe (Lookup a) +lookupR0 openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + lookupR_ (\b arr -> Lookup (Build $ Snoc b arr)) openness step w z t + + _ -> + case openness of + Closed | Just x <- mx -> Just $ Lookup (Build Lin) x + + _ -> case t of + Nil -> Nothing + _ -> let !(# b, arr, x #) = unsafeLookupMinWithKey_ Lin t + in Just $! Lookup (Build $ Snoc b arr) x + +{-# INLINE lookupR1 #-} +lookupR1 :: Openness -> Feed1 -> Radix1Tree a -> Maybe (Lookup1 a) +lookupR1 openness (Feed1 w feed) = + feed $ \step -> lookupR_ (\b arr -> Lookup1 (Build1 (b :/ arr))) openness step w + +{-# INLINE lookupR_ #-} +lookupR_ + :: (Tsil ByteArray -> ByteArray -> a -> b) + -> Openness -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Maybe b +lookupR_ f openness step = go Lin Nothing + where + getMin b t = + let !(# b', arr, a #) = unsafeLookupMinWithKey_ b t + in Just $! f b' arr a + + go b getR w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go b (getMin b r) w s l + else getMin b l + + else if w <= upper p + then go b getR w s r + else getR + + Tip arr mx dx -> goarr w s 0 + where + getThis = f b arr `fmap'` mx + + getBelow = + case dx of + Nil -> Nothing + _ -> getMin (Snoc b arr) dx + + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> go (Snoc b arr) getR u z' dx + Done -> + ( case openness of + Open -> getBelow + Closed -> getThis <|> getBelow + ) + <|> getR + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> (getThis <|> getBelow) <|> getR + + GT -> getThis <|> getBelow + + LT -> getR + + Nil -> getR + + + +{-# INLINE adjustL0 #-} +adjustL0 :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustL0 f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree (f <$> mx) $ adjustL_ f openness step w z t + Done -> + case openness of + Open -> t0 + Closed -> case mx of + Just x -> RadixTree (Just $ f x) t + Nothing -> t0 + +{-# INLINE adjustL1 #-} +adjustL1 :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustL1 f openness (Feed1 w feed) = + feed $ \step -> adjustL_ f openness step w + +{-# INLINE adjustL_ #-} +adjustL_ + :: (a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustL_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go w s l) r + else t + + else if w <= upper p + then Bin p (map1 f l) (go w s r) + else map1 f t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr (f <$> mx) $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f <$> mx + + in Tip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> map1 f t + + GT -> t + + Nil -> Nil + + + +{-# INLINE adjustLWithKey0 #-} +adjustLWithKey0 :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustLWithKey0 f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree (f (Build Lin) <$> mx) $ + adjustLWithKey_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + Done -> + case openness of + Open -> t0 + Closed -> RadixTree (f (Build Lin) <$> mx) t + +{-# INLINE adjustLWithKey1 #-} +adjustLWithKey1 :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustLWithKey1 f openness (Feed1 w feed) = + feed $ \step -> adjustLWithKey_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE adjustLWithKey_ #-} +adjustLWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustLWithKey_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go b w s l) r + else t + + else if w <= upper p + then Bin p (mapWithKey_ f b l) (go b w s r) + else mapWithKey_ f b t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr (f b arr <$> mx) $ + go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr <$> mx + + in Tip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> mapWithKey_ f b t + + GT -> t + + Nil -> Nil + + + +{-# INLINE adjustR0 #-} +adjustR0 :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustR0 f openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ adjustR_ f openness step w z t + Done -> + let my = case openness of + Open -> mx + Closed -> f <$> mx + + in RadixTree my (map1 f t) + +{-# INLINE adjustR1 #-} +adjustR1 :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustR1 f openness (Feed1 w feed) = + feed $ \step -> adjustR_ f openness step w + +{-# INLINE adjustR_ #-} +adjustR_ + :: (a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustR_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go w s l) (map1 f r) + else map1 f t + + else if w <= upper p + then Bin p l (go w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr mx $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f <$> mx + + in Tip arr my $ map1 f dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> map1 f t + + GT -> map1 f t + + LT -> t + + Nil -> Nil + + + +{-# INLINE adjustRWithKey0 #-} +adjustRWithKey0 :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustRWithKey0 f openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + RadixTree mx $ + adjustRWithKey_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + + Done -> + let my = case openness of + Open -> mx + Closed -> f (Build Lin) <$> mx + + in RadixTree my $ mapWithKey_ (\b arr -> f (Build $ Snoc b arr)) Lin t + +{-# INLINE adjustRWithKey1 #-} +adjustRWithKey1 :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustRWithKey1 f openness (Feed1 w feed) = + feed $ \step -> adjustRWithKey_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE adjustRWithKey_ #-} +adjustRWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustRWithKey_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go b w s l) (mapWithKey_ f b r) + else mapWithKey_ f b t + + else if w <= upper p + then Bin p l (go b w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr mx $ go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr <$> mx + + in Tip arr my $ mapWithKey_ f (Snoc b arr) dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> mapWithKey_ f b t + + GT -> mapWithKey_ f b t + + LT -> t + + Nil -> Nil + + + +{-# INLINE updateL0 #-} +updateL0 :: (a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateL0 f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree (f =<< mx) $ updateL_ f openness step w z t + Done -> + case openness of + Open -> t0 + Closed -> RadixTree (f =<< mx) t + +{-# INLINE updateL1 #-} +updateL1 :: (a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateL1 f openness (Feed1 w feed) = + feed $ \step -> updateL_ f openness step w + +{-# INLINE updateL_ #-} +updateL_ + :: (a -> Maybe a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +updateL_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go w s l) r + else t + + else if w <= upper p + then rebin p (mapMaybe1 f l) (go w s r) + else mapMaybe1 f t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr (f =<< mx) $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f =<< mx + + in retip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> mapMaybe1 f t + + GT -> t + + Nil -> Nil + + + +{-# INLINE updateLWithKey0 #-} +updateLWithKey0 + :: (Build -> a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateLWithKey0 f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + RadixTree (f (Build Lin) =<< mx) $ + updateLWithKey_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + + Done -> + case openness of + Open -> t0 + Closed -> RadixTree (f (Build Lin) =<< mx) t + +{-# INLINE updateLWithKey1 #-} +updateLWithKey1 + :: (Build1 -> a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateLWithKey1 f openness (Feed1 w feed) = + feed $ \step -> updateLWithKey_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE updateLWithKey_ #-} +updateLWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +updateLWithKey_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go b w s l) r + else t + + else if w <= upper p + then rebin p (mapMaybeWithKey_ f b l) (go b w s r) + else mapMaybeWithKey_ f b t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr (f b arr =<< mx) $ + go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr =<< mx + + in retip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> mapMaybeWithKey_ f b t + + GT -> t + + Nil -> Nil + + + +{-# INLINE updateR0 #-} +updateR0 :: (a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateR0 f openness (Feed feed) (RadixTree mx t) = + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ updateR_ f openness step w z t + Done -> + let my = case openness of + Open -> mx + Closed -> f =<< mx + + in RadixTree my (mapMaybe1 f t) + +{-# INLINE updateR1 #-} +updateR1 :: (a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateR1 f openness (Feed1 w feed) = + feed $ \step -> updateR_ f openness step w + +{-# INLINE updateR_ #-} +updateR_ + :: (a -> Maybe a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +updateR_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebin p (go w s l) (mapMaybe1 f r) + else mapMaybe1 f t + + else if w <= upper p + then rebinR p l (go w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr mx $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f =<< mx + + in retip arr my $ mapMaybe1 f dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> mapMaybe1 f t + + GT -> mapMaybe1 f t + + LT -> t + + Nil -> Nil + + + +{-# INLINE updateRWithKey0 #-} +updateRWithKey0 + :: (Build -> a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateRWithKey0 f openness (Feed feed) (RadixTree mx t) = + feed $ \step s -> + case step s of + More w z -> + RadixTree mx $ + updateRWithKey_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + + Done -> + let my = case openness of + Open -> mx + Closed -> f (Build Lin) =<< mx + + in RadixTree my (mapMaybeWithKey_ (\b arr -> f (Build $ Snoc b arr)) Lin t) + +{-# INLINE updateRWithKey1 #-} +updateRWithKey1 + :: (Build1 -> a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateRWithKey1 f openness (Feed1 w feed) = + feed $ \step -> updateRWithKey_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE updateRWithKey_ #-} +updateRWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +updateRWithKey_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebin p (go b w s l) (mapMaybeWithKey_ f b r) + else mapMaybeWithKey_ f b t + + else if w <= upper p + then rebinR p l (go b w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr mx $ go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr =<< mx + + in retip arr my $ mapMaybeWithKey_ f (Snoc b arr) dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> mapMaybeWithKey_ f b t + + GT -> mapMaybeWithKey_ f b t + + LT -> t + + Nil -> Nil + + + +{-# INLINE takeL0 #-} +takeL0 :: Openness -> Feed -> RadixTree a -> RadixTree a +takeL0 openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ takeL_ openness step w z t + Done -> + let my = case openness of + Open -> Nothing + Closed -> mx + + in RadixTree my Nil + +{-# INLINE takeL1 #-} +takeL1 :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +takeL1 openness (Feed1 w0 feed) = feed $ \step -> takeL_ openness step w0 + +{-# INLINE takeL_ #-} +takeL_ :: Openness -> (x -> Step Prefix x) -> Prefix -> x -> Radix1Tree a -> Radix1Tree a +takeL_ openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go w s l + else Nil + + else if w <= upper p + then rebinR p l (go w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr mx $ go u z' dx + Done -> + case openness of + Open -> Nil + Closed -> retip arr mx Nil + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> Nil + + LT -> t + + GT -> Nil + + Nil -> Nil + + + +{-# INLINE takeR0 #-} +takeR0 :: Openness -> Feed -> RadixTree a -> RadixTree a +takeR0 openness (Feed feed) (RadixTree mx t) = + feed $ \step s -> + case step s of + More w z -> RadixTree Nothing $ takeR_ openness step w z t + Done -> + let my = case openness of + Open -> Nothing + Closed -> mx + + in RadixTree my t + +{-# INLINE takeR1 #-} +takeR1 :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +takeR1 openness (Feed1 w0 feed) = feed $ \step -> takeR_ openness step w0 + +{-# INLINE takeR_ #-} +takeR_ :: Openness -> (x -> Step Prefix x) -> Prefix -> x -> Radix1Tree a -> Radix1Tree a +takeR_ openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go w s l) r + else t + + else if w <= upper p + then go w s r + else Nil + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr Nothing $ go u z' dx + Done -> + let my = case openness of + Open -> Nothing + Closed -> mx + + in retip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + GT -> t + + LT -> Nil + + Nil -> Nil + + + +type UBin a = (# Prefix, Radix1Tree a, Radix1Tree a #) + +type UTip a = (# Key, Int, ByteArray, Maybe a, Radix1Tree a #) + + + +union0 :: RadixTree a -> RadixTree a -> RadixTree a +union0 (RadixTree mA tA) (RadixTree mB tB) = RadixTree (mA <|> mB) (union1 tA tB) + +union1 :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +union1 = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> tB + + tipAny uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip uA tA uB tB lenA + else tipTip uB tB uA tA lenB + + Nil | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + tipTip (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then Tip arrA' (mA <|> mB) (anyAny dA dB) + else Tip arrA' mA $ + tipAny (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | o == 1 = + let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + !tB' | nB == 0 = tB + | otherwise = Tip (dropByteArray nB arrB) mB dB + + in join wA tA' wB tB' + + | otherwise = + let !o' = o - 1 + + !(# !arrC, !arrA' #) = splitByteArray nA o' arrA + + !arrB' = dropByteArray (nB + o') arrB + + in Tip arrC Nothing $ join wA (Tip arrA' mA dA) + wB (Tip arrB' mB dB) + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + in tipBin (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> tA + + tipBin uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + in join wA tA' pB tB + + | wA < pB = Bin pB (tipAny uA tA lB) rB + | otherwise = Bin pB lB (tipAny uA tA rB) + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> Bin pA lA (binAny uB tB rA) + | pA >= lower pB -> Bin pB (binAny uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny uA tA rB) + | pB >= lower pA -> Bin pA (binAny uB tB lA) rA + | otherwise -> no + + + +unionL0 :: RadixTree a -> RadixTree a -> RadixTree a +unionL0 (RadixTree mA tA) (RadixTree mB tB) = RadixTree (mA <|> mB) (unionL1 tA tB) + +unionL1 :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionL1 = + union_ $ \s a b -> + let !(# c #) = case s of + L -> (# a #) + R -> (# b #) + in Just c + + +unionWith0 :: (a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a +unionWith0 f (RadixTree mA tA) (RadixTree mB tB) = + let mC = case mA of + Just a -> case mB of + Just b -> Just $ f a b + Nothing -> mA + + Nothing -> mB + + in RadixTree mC (unionWith1 f tA tB) + +unionWith1 :: (a -> a -> a) -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionWith1 f = + union_ $ \s a b -> + let !(# c #) = case s of + L -> (# f a b #) + R -> (# f b a #) + in Just c + + + +{-# INLINE union_ #-} +union_ + :: (forall x y. S x y a a -> x -> y -> Maybe a) + -> Radix1Tree a + -> Radix1Tree a + -> Radix1Tree a +union_ f = anyAny L + where + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> tB + + tipAny s uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' uB tB uA tA lenB + + Nil | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + tipTip s (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC = case mA of + Just a -> case mB of + Just b -> f s a b + Nothing -> mA + + Nothing -> mB + + in Tip arrA' mC (anyAny s dA dB) + + else Tip arrA' mA $ + let !(# s' #) = other s + in tipAny s' (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | o == 1 = + let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + !tB' | nB == 0 = tB + | otherwise = Tip (dropByteArray nB arrB) mB dB + + in join wA tA' wB tB' + + | otherwise = + let !o' = o - 1 + + !(# !arrC, !arrA' #) = splitByteArray nA o' arrA + + !arrB' = dropByteArray (nB + o') arrB + + in Tip arrC Nothing $ join wA (Tip arrA' mA dA) + wB (Tip arrB' mB dB) + + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> tA + + tipBin s uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + in join wA tA' pB tB + + | wA < pB = Bin pB (tipAny s uA tA lB) rB + | otherwise = Bin pB lB (tipAny s uA tA rB) + + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in Bin pA lA (binAny s' uB tB rA) + | pA >= lower pB -> Bin pB (binAny s uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny s uA tA rB) + | pB >= lower pA -> let !(# s' #) = other s + in Bin pA (binAny s' uB tB lA) rA + | otherwise -> no + + + + +unionWithKey0 :: (Build -> a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a +unionWithKey0 f (RadixTree mA tA) (RadixTree mB tB) = + let mC = case mA of + Just a -> case mB of + Just b -> Just $ f (Build Lin) a b + Nothing -> mA + + Nothing -> mB + + in RadixTree mC $ unionWithKey_ + ( \s b arr vA vB -> + let b0 = Build $ Snoc b arr + + !(# c #) = case s of + L -> (# f b0 vA vB #) + R -> (# f b0 vB vA #) + + in Just c + ) + tA tB + +unionWithKey1 :: (Build1 -> a -> a -> a) -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionWithKey1 f = + unionWithKey_ $ \s b arr vA vB -> + let b1 = Build1 $ b :/ arr + + !(# c #) = case s of + L -> (# f b1 vA vB #) + R -> (# f b1 vB vA #) + in Just c + +{-# INLINE unionWithKey_ #-} +unionWithKey_ + :: (forall x y. S x y a a -> Tsil ByteArray -> ByteArray -> x -> y -> Maybe a) + -> Radix1Tree a + -> Radix1Tree a + -> Radix1Tree a +unionWithKey_ f = anyAny L Lin + where + anyAny s b tA tB = + case tA of + Bin pA lA rA -> binAny s b (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s b (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> tB + + tipAny s b uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s b uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' b uB tB uA tA lenB + + Nil | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + tipTip s b (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC = + case mA of + Just xA -> + case mB of + Just xB -> f s b arrA' xA xB + Nothing -> mA + + Nothing -> mB + + in Tip arrA' mC (anyAny s (Snoc b arrA') dA dB) + + else Tip arrA' mA $ + let !(# s' #) = other s + in tipAny s' (Snoc b arrA') + (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | o == 1 = + let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + !tB' | nB == 0 = tB + | otherwise = Tip (dropByteArray nB arrB) mB dB + + in join wA tA' wB tB' + + | otherwise = + let !o' = o - 1 + + !(# !arrC, !arrA' #) = splitByteArray nA o' arrA + + !arrB' = dropByteArray (nB + o') arrB + + in Tip arrC Nothing $ join wA (Tip arrA' mA dA) + wB (Tip arrB' mB dB) + + binAny s b uA tA tB = + case tB of + Bin pB lB rB -> binBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' b (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> tA + + tipBin s b uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + in join wA tA' pB tB + + | wA < pB = Bin pB (tipAny s b uA tA lB) rB + | otherwise = Bin pB lB (tipAny s b uA tA rB) + + binBin s b uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny s b lA lB) (anyAny s b rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in Bin pA lA (binAny s' b uB tB rA) + | pA >= lower pB -> Bin pB (binAny s b uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny s b uA tA rB) + | pB >= lower pA -> let !(# s' #) = other s + in Bin pA (binAny s' b uB tB lA) rA + | otherwise -> no + + + +difference0 :: RadixTree a -> RadixTree b -> RadixTree a +difference0 (RadixTree mA tA) (RadixTree mB tB) = + let mC = case mB of + Just _ -> Nothing + Nothing -> mA + + in RadixTree mC $ difference1 tA tB + +difference1 :: Radix1Tree a -> Radix1Tree b -> Radix1Tree a +difference1 = + difference_ $ \_ _ _ -> + Nothing + + +differenceWith0 + :: (a -> b -> Maybe a) -> RadixTree a -> RadixTree b -> RadixTree a +differenceWith0 f (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just xA <- mA, Just xB <- mB = f xA xB + | otherwise = mA + + in RadixTree mC $ differenceWith1 f tA tB + +differenceWith1 + :: (a -> b -> Maybe a) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree a +differenceWith1 f = + difference_ $ \s xA xB -> + case s of + L -> f xA xB + R -> f xB xA + +{-# INLINE difference_ #-} +difference_ + :: (forall x y. S x y a b -> x -> y -> Maybe a) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree a +difference_ (f :: forall n o. S n o x y -> n -> o -> Maybe x) = anyAny L + where + anyAny :: forall a b. S a b x y -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> case s of + L -> Nil + R -> tB + + tipAny + :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + tipAny s uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' uB tB uA tA lenB + + Nil -> case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R -> Nil + + tipTip + :: forall a b. S a b x y + -> UTip a -> Radix1Tree a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree x + tipTip s (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just xA <- mA, Just xB <- mB = f s xA xB + | otherwise = + case s of + L -> mA + R -> mB + + in retip arrA' mC (anyAny s dA dB) + + else let mA' = case s of + L -> mA + R -> Nothing + + in retip arrA' mA' $ + let !(# s' #) = other s + in tipAny s' (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = + case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R | nB == 0 -> tB + | otherwise -> Tip (dropByteArray nB arrB) mB dB + + binAny + :: forall a b. S a b x y -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> case s of + L -> tA + R -> tB + + tipBin + :: forall a b. S a b x y + -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree x + tipBin s uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R -> tB + + | wA < pB = case s of + L -> tipAny s uA tA lB + R -> rebinL pB (tipAny s uA tA lB) rB + + | otherwise = case s of + L -> tipAny s uA tA rB + R -> rebinR pB lB (tipAny s uA tA rB) + + binBin + :: forall a b. S a b x y + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree x + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let no = case s of + L -> tA + R -> tB + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> case s of + L -> rebinR pA lA (binAny R uB tB rA) + R -> binAny L uB tB rA + + | pA >= lower pB -> case s of + L -> binAny s uA tA lB + R -> rebinL pB (binAny s uA tA lB) rB + + | otherwise -> no + + GT | pA <= upper pB -> case s of + L -> binAny s uA tA rB + R -> rebinR pB lB (binAny s uA tA rB) + + | pB >= lower pA -> case s of + L -> rebinL pA (binAny R uB tB lA) rA + R -> binAny L uB tB lA + + | otherwise -> no + + + +differenceWithKey0 + :: (Build -> a -> b -> Maybe a) -> RadixTree a -> RadixTree b -> RadixTree a +differenceWithKey0 f (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just xA <- mA, Just xB <- mB = f (Build Lin) xA xB + | otherwise = mA + + in RadixTree mC $ differenceWithKey_ + ( \s b arr xA xB -> + let b0 = Build $ Snoc b arr + in case s of + L -> f b0 xA xB + R -> f b0 xB xA + ) + tA tB + +differenceWithKey1 + :: (Build1 -> a -> b -> Maybe a) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree a +differenceWithKey1 f = + differenceWithKey_ $ \s b arr xA xB -> + let b1 = Build1 $ b :/ arr + in case s of + L -> f b1 xA xB + R -> f b1 xB xA + +{-# INLINE differenceWithKey_ #-} +differenceWithKey_ + :: (forall x y. S x y a b -> Tsil ByteArray -> ByteArray -> x -> y -> Maybe a) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree a +differenceWithKey_ + (f :: forall n o. S n o x y -> Tsil ByteArray -> ByteArray -> n -> o -> Maybe x) = + anyAny L Lin + where + anyAny + :: forall a b. S a b x y -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + anyAny s b tA tB = + case tA of + Bin pA lA rA -> binAny s b (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s b (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> case s of + L -> Nil + R -> tB + + tipAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + tipAny s b uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s b uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' b uB tB uA tA lenB + + Nil -> case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R -> Nil + + tipTip + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree x + tipTip s b (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just xA <- mA, Just xB <- mB = + f s b arrA' xA xB + + | otherwise = + case s of + L -> mA + R -> mB + + in retip arrA' mC (anyAny s (Snoc b arrA') dA dB) + + else let mA' = case s of + L -> mA + R -> Nothing + + in retip arrA' mA' $ + let !(# s' #) = other s + in tipAny s' (Snoc b arrA') + (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = + case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R | nB == 0 -> tB + | otherwise -> Tip (dropByteArray nB arrB) mB dB + + binAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + binAny s b uA tA tB = + case tB of + Bin pB lB rB -> binBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' b (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> case s of + L -> tA + R -> tB + + tipBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree x + tipBin s b uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R -> tB + + | wA < pB = case s of + L -> tipAny s b uA tA lB + R -> rebinL pB (tipAny s b uA tA lB) rB + + | otherwise = case s of + L -> tipAny s b uA tA rB + R -> rebinR pB lB (tipAny s b uA tA rB) + + binBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree x + binBin s b uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let no = case s of + L -> tA + R -> tB + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s b lA lB) (anyAny s b rA rB) + + LT | pB <= upper pA -> case s of + L -> rebinR pA lA (binAny R b uB tB rA) + R -> binAny L b uB tB rA + + | pA >= lower pB -> case s of + L -> binAny s b uA tA lB + R -> rebinL pB (binAny s b uA tA lB) rB + + | otherwise -> no + + GT | pA <= upper pB -> case s of + L -> binAny s b uA tA rB + R -> rebinR pB lB (binAny s b uA tA rB) + + | pB >= lower pA -> case s of + L -> rebinL pA (binAny R b uB tB lA) rA + R -> binAny L b uB tB lA + + | otherwise -> no + + + +compare0 :: (a -> b -> Bool) -> RadixTree a -> RadixTree b -> PartialOrdering +compare0 f (RadixTree mA tA) (RadixTree mB tB) = + let o = case mA of + Just xA -> case mB of + Just xB + | f xA xB -> Equal + | otherwise -> Incomparable + + Nothing -> Superset + + Nothing -> case mB of + Just _ -> Subset + Nothing -> Equal + + in order o $ Data.RadixNTree.Word8.Lazy.compare1 f tA tB + +compare1 :: (a -> b -> Bool) -> Radix1Tree a -> Radix1Tree b -> PartialOrdering +compare1 (f :: x -> y -> Bool) = anyAny L + where + anyAny :: forall a b. S a b x y -> Radix1Tree a -> Radix1Tree b -> PartialOrdering + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> case tB of + Nil -> Equal + _ -> case s of + L -> Subset + R -> Superset + + tipAny + :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> Radix1Tree b -> PartialOrdering + tipAny s uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s uA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' uB uA tA lenB + + Nil -> case s of + L -> Superset + R -> Subset + + tipTip + :: forall a b. S a b x y -> UTip a -> UTip b -> Radix1Tree b -> Int -> PartialOrdering + tipTip s (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then if nB' == sizeofByteArray arrB + then let o_ = case mA of + Just xA -> case mB of + Just xB -> + let eq = case s of + L -> f xA xB + R -> f xB xA + + in if eq + then Equal + else Incomparable + + Nothing -> case s of + L -> Superset + R -> Subset + Nothing -> case mB of + Just _ -> case s of + L -> Subset + R -> Superset + + Nothing -> Equal + + in order o_ $ anyAny s dA dB + + else let !(# s' #) = other s + in tipAny s' (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = case s of + L -> Superset + R -> Subset + + binAny + :: forall a b. S a b x y -> UBin a -> Radix1Tree a -> Radix1Tree b -> PartialOrdering + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> case s of + L -> Superset + R -> Subset + + tipBin :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> UBin b -> PartialOrdering + tipBin s uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = Incomparable + | otherwise = limit s . tipAny s uA tA $ if wA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> PartialOrdering + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> order (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in limit s' $ binAny s' uB tB rA + | pA >= lower pB -> limit s $ binAny s uA tA lB + | otherwise -> Incomparable + + GT | pA <= upper pB -> limit s $ binAny s uA tA rB + | pB >= lower pA -> let !(# s' #) = other s + in limit s' $ binAny s' uB tB lA + | otherwise -> Incomparable + + + +disjoint0 :: RadixTree a -> RadixTree b -> Bool +disjoint0 (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just _ <- mA, Just _ <- mB = False + | otherwise = True + + in mC && disjoint1 tA tB + +disjoint1 :: Radix1Tree a -> Radix1Tree b -> Bool +disjoint1 = anyAny + where + anyAny :: forall a b. Radix1Tree a -> Radix1Tree b -> Bool + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> True + + tipAny :: forall a b. UTip a -> Radix1Tree a -> Radix1Tree b -> Bool + tipAny uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip uA uB tB lenA + + else tipTip uB uA tA lenB + + Nil -> True + + tipTip :: forall a b. UTip a -> UTip b -> Radix1Tree b -> Int -> Bool + tipTip (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then if nB' == sizeofByteArray arrB + then let mC | Just _ <- mA, Just _ <- mB = False + | otherwise = True + + in mC && anyAny dA dB + + else tipAny (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = True + + binAny :: forall a b. UBin a -> Radix1Tree a -> Radix1Tree b -> Bool + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + in tipBin (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> True + + tipBin :: forall a b. UTip a -> Radix1Tree a -> UBin b -> Bool + tipBin uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = True + | otherwise = tipAny uA tA $ if wA < pB + then lB + else rB + + binBin :: forall a b. UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Bool + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> anyAny lA lB && anyAny rA rB + + LT | pB <= upper pA -> binAny uB tB rA + | pA >= lower pB -> binAny uA tA lB + | otherwise -> True + + GT | pA <= upper pB -> binAny uA tA rB + | pB >= lower pA -> binAny uB tB lA + | otherwise -> True + + + +intersection0 :: RadixTree a -> RadixTree a -> RadixTree a +intersection0 (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just _ <- mA, Just _ <- mB = mA + | otherwise = Nothing + + in RadixTree mC (intersection1 tA tB) + +intersection1 :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +intersection1 = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> Nil + + tipAny uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip uA uB tB lenA + + else tipTip uB uA tA lenB + + Nil -> Nil + + tipTip (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just _ <- mA, Just _ <- mB = mA + | otherwise = Nothing + + in retip arrA' mC (anyAny dA dB) + + else retip arrA' Nothing $ + tipAny (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = Nil + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + in tipBin (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> Nil + + tipBin uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = Nil + | otherwise = tipAny uA tA $ if wA < pB + then lB + else rB + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> binAny uB tB rA + | pA >= lower pB -> binAny uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny uA tA rB + | pB >= lower pA -> binAny uB tB lA + | otherwise -> Nil + + + +intersectionL0 :: RadixTree a -> RadixTree b -> RadixTree a +intersectionL0 (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just _ <- mA, Just _ <- mB = mA + | otherwise = Nothing + + in RadixTree mC (intersectionL1 tA tB) + +intersectionL1 :: Radix1Tree a -> Radix1Tree b -> Radix1Tree a +intersectionL1 = + intersection_ $ \s a b -> + let !(# c #) = case s of + L -> (# a #) + R -> (# b #) + in Just c + + +intersectionWith0 :: (a -> b -> c) -> RadixTree a -> RadixTree b -> RadixTree c +intersectionWith0 f (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just a <- mA, Just b <- mB = Just $ f a b + | otherwise = Nothing + + in RadixTree mC (intersectionWith1 f tA tB) + +intersectionWith1 :: (a -> b -> c) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c +intersectionWith1 f = + intersection_ $ \s a b -> + let !(# c #) = case s of + L -> (# f a b #) + R -> (# f b a #) + in Just c + +{-# INLINE intersection_ #-} +intersection_ + :: (forall x y. S x y a b -> x -> y -> Maybe c) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +intersection_ (f :: forall n o. S n o x y -> n -> o -> Maybe c) = anyAny L + where + anyAny :: forall a b. S a b x y -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> Nil + + tipAny + :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + tipAny s uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s uA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' uB uA tA lenB + + Nil -> Nil + + tipTip + :: forall a b. S a b x y -> UTip a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree c + tipTip s (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just xA <- mA, Just xB <- mB = f s xA xB + | otherwise = Nothing + + in retip arrA' mC (anyAny s dA dB) + + else retip arrA' Nothing $ + let !(# s' #) = other s + in tipAny s' (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = Nil + + binAny + :: forall a b. S a b x y -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> Nil + + tipBin :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree c + tipBin s uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = Nil + | otherwise = tipAny s uA tA $ if wA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree c + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in binAny s' uB tB rA + | pA >= lower pB -> binAny s uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny s uA tA rB + | pB >= lower pA -> let !(# s' #) = other s + in binAny s' uB tB lA + | otherwise -> Nil + + + +intersectionWithKey0 + :: (Build -> a -> b -> c) -> RadixTree a -> RadixTree b -> RadixTree c +intersectionWithKey0 f (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just a <- mA, Just b <- mB = Just $ f (Build Lin) a b + | otherwise = Nothing + + in RadixTree mC $ intersectionWithKey_ + ( \s b arr vA vB -> + let b0 = Build $ Snoc b arr + + !(# c #) = case s of + L -> (# f b0 vA vB #) + R -> (# f b0 vB vA #) + + in Just c + ) + tA tB + +intersectionWithKey1 + :: (Build1 -> a -> b -> c) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c +intersectionWithKey1 f = + intersectionWithKey_ $ \s b arr vA vB -> + let b1 = Build1 $ b :/ arr + + !(# c #) = case s of + L -> (# f b1 vA vB #) + R -> (# f b1 vB vA #) + + in Just c + +{-# INLINE intersectionWithKey_ #-} +intersectionWithKey_ + :: (forall x y. S x y a b -> Tsil ByteArray -> ByteArray -> x -> y -> Maybe c) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +intersectionWithKey_ + (f :: forall n o. S n o x y -> Tsil ByteArray -> ByteArray -> n -> o -> Maybe c) = + anyAny L Lin + where + anyAny + :: forall a b. S a b x y -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + anyAny s b tA tB = + case tA of + Bin pA lA rA -> binAny s b (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s b (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> Nil + + tipAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + tipAny s b uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin s b uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s b uA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' b uB uA tA lenB + + Nil -> Nil + + tipTip + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree c + tipTip s b (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just xA <- mA, Just xB <- mB = + f s b arrA' xA xB + + | otherwise = Nothing + + + in retip arrA' mC (anyAny s (Snoc b arrA') dA dB) + + else retip arrA' Nothing $ + let !(# s' #) = other s + in tipAny s' (Snoc b arrA') + (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = Nil + + binAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + binAny s b uA tA tB = + case tB of + Bin pB lB rB -> binBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' b (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> Nil + + tipBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree c + tipBin s b uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = Nil + | otherwise = tipAny s b uA tA $ if wA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree c + binBin s b uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s b lA lB) (anyAny s b rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in binAny s' b uB tB rA + | pA >= lower pB -> binAny s b uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny s b uA tA rB + | pB >= lower pA -> let !(# s' #) = other s + in binAny s' b uB tB lA + | otherwise -> Nil + + + +{-# INLINE merge0 #-} +merge0 + :: (Build -> a -> b -> Maybe c) + -> (Build -> a -> Maybe c) + -> (Build -> Radix1Tree a -> Radix1Tree c) + -> (Build -> b -> Maybe c) + -> (Build -> Radix1Tree b -> Radix1Tree c) + -> RadixTree a + -> RadixTree b + -> RadixTree c +merge0 f oneX treeX oneY treeY = \(RadixTree mA tA) (RadixTree mB tB) -> + let mC = case mA of + Just xA -> case mB of + Just xB -> f (Build Lin) xA xB + Nothing -> oneX (Build Lin) xA + + Nothing -> case mB of + Just xB -> oneY (Build Lin) xB + Nothing -> Nothing + + in RadixTree mC $ + merge_ (\b arr -> f (Build $ Snoc b arr)) + (\b arr -> oneX (Build $ Snoc b arr)) treeX + (\b arr -> oneY (Build $ Snoc b arr)) treeY + tA tB + +{-# INLINE merge1 #-} +merge1 + :: (Build1 -> a -> b -> Maybe c) + -> (Build1 -> a -> Maybe c) + -> (Build -> Radix1Tree a -> Radix1Tree c) + -> (Build1 -> b -> Maybe c) + -> (Build -> Radix1Tree b -> Radix1Tree c) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +merge1 f oneX treeX oneY treeY = + merge_ (\b arr -> f (Build1 $ b :/ arr)) + (\b arr -> oneX (Build1 $ b :/ arr)) treeX + (\b arr -> oneY (Build1 $ b :/ arr)) treeY + +{-# INLINE merge_ #-} +merge_ + :: (Tsil ByteArray -> ByteArray -> a -> b -> Maybe c) + -> (Tsil ByteArray -> ByteArray -> a -> Maybe c) + -> (Build -> Radix1Tree a -> Radix1Tree c) + -> (Tsil ByteArray -> ByteArray -> b -> Maybe c) + -> (Build -> Radix1Tree b -> Radix1Tree c) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +merge_ (f :: Tsil ByteArray -> ByteArray -> x -> y -> Maybe c) oneX treeX oneY treeY = + anyAny L Lin + where + sideA :: forall a b. S a b x y -> Tsil ByteArray -> Radix1Tree a -> Radix1Tree c + sideA s b tA = case s of + L -> treeX (Build b) tA + R -> treeY (Build b) tA + + sideB :: forall a b. S a b x y -> Tsil ByteArray -> Radix1Tree b -> Radix1Tree c + sideB s b tB = case s of + L -> treeY (Build b) tB + R -> treeX (Build b) tB + + anyAny + :: forall a b. S a b x y -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + anyAny s b tA tB = + case tA of + Bin pA lA rA -> binAny s b (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s b (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> sideB s b tB + + tipAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + tipAny s b uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s b uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' b uB tB uA tA lenB + + Nil -> sideA s b $ if nA == 0 + then tA + else Tip (dropByteArray nA arrA) mA dA + + tipTip + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree c + tipTip s b (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC = case mA of + Just xA -> + case mB of + Just xB -> case s of + L -> f b arrA' xA xB + R -> f b arrA' xB xA + + Nothing -> case s of + L -> oneX b arrA' xA + R -> oneY b arrA' xA + + Nothing -> + case mB of + Just xB -> case s of + L -> oneY b arrA' xB + R -> oneX b arrA' xB + + Nothing -> Nothing + + in retip arrA' mC (anyAny s (Snoc b arrA') dA dB) + + else let mC = case mA of + Just xA -> case s of + L -> oneX b arrA' xA + R -> oneY b arrA' xA + + Nothing -> Nothing + + in retip arrA' mC $ + let !(# s' #) = other s + in tipAny s' (Snoc b arrA') + (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | o == 1 = + safeJoin wA ( sideA s b $ if nA == 0 + then tA + else Tip (dropByteArray nA arrA) mA dA + ) + wB ( sideB s b $ if nB == 0 + then tB + else Tip (dropByteArray nB arrB) mB dB + ) + + | otherwise = + let !o' = o - 1 + + !(# !arrC, !arrA' #) = splitByteArray nA o' arrA + + !arrB' = dropByteArray (nB + o') arrB + + in retip arrC Nothing $ safeJoin wA (sideA s b $ Tip arrA' mA dA) + wB (sideB s b $ Tip arrB' mB dB) + + binAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + binAny s b uA tA tB = + case tB of + Bin pB lB rB -> binBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' b (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> sideA s b tA + + tipBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree c + tipBin s b uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = safeJoin wA (sideA s b $ if nA == 0 + then tA + else Tip (dropByteArray nA arrA) mA dA + ) + pB (sideB s b tB) + + | wA < pB = rebin pB (tipAny s b uA tA lB) (sideB s b rB) + + | otherwise = rebin pB (sideB s b lB) (tipAny s b uA tA rB) + + binBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree c + binBin s b uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = safeJoin pA (sideA s b tA) pB (sideB s b tB) + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s b lA lB) (anyAny s b rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + + in rebin pA (sideA s b lA) (binAny s' b uB tB rA) + + | pA >= lower pB -> rebin pB (binAny s b uA tA lB) (sideB s b rB) + + | otherwise -> no + + GT | pA <= upper pB -> rebin pB (sideB s b lB) (binAny s b uA tA rB) + + | pB >= lower pA -> let !(# s' #) = other s + + in rebin pA (binAny s' b uB tB lA) (sideA s b rA) + + | otherwise -> no + + + +{-# INLINE insert0 #-} +insert0 :: Feed -> a -> RadixTree a -> RadixTree a +insert0 (Feed feed) a = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ insert_ a step w z t + Done -> RadixTree (Just a) t + +{-# INLINE insert1 #-} +insert1 :: Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insert1 (Feed1 w feed) a = + feed $ \step -> insert_ a step w + +{-# INLINE insert_ #-} +insert_ :: a -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +insert_ a step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> join + w (singleton_ step w s a) + p t + + | w < p -> Bin p (go w s l) r + | otherwise -> Bin p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> Tip arr mx (go u z' dx) + Done -> Tip arr (Just a) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> + let !(# !brr, !crr #) = splitByteArray 0 (n + 1) arr + in Tip brr (Just a) (Tip crr mx dx) + + | n == 0 = + join + (indexByteArray arr 0) t + w (singleton_ step w s a) + + | otherwise = + let !(# !brr, !crr #) = splitByteArray 0 n arr + in Tip brr Nothing $ + join + (indexByteArray crr 0) (Tip crr mx dx) + v (singleton_ step v z a) + + Nil -> singleton_ step w s a + + + +{-# INLINE insertWith0 #-} +insertWith0 :: (a -> a) -> Feed -> a -> RadixTree a -> RadixTree a +insertWith0 f (Feed feed) a = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ insertWith_ f a step w z t + Done -> + let y = case mx of + Just x -> f x + Nothing -> a + + in RadixTree (Just y) t + +{-# INLINE insertWith1 #-} +insertWith1 :: (a -> a) -> Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insertWith1 f (Feed1 w feed) a = + feed $ \step -> insertWith_ f a step w + +{-# INLINE insertWith_ #-} +insertWith_ + :: (a -> a) -> a -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +insertWith_ f a step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> join + w (singleton_ step w s a) + p t + + | w < p -> Bin p (go w s l) r + | otherwise -> Bin p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> Tip arr mx (go u z' dx) + Done -> let y = case mx of + Just x -> f x + Nothing -> a + + in Tip arr (Just y) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> + let !(# !brr, !crr #) = splitByteArray 0 (n + 1) arr + in Tip brr (Just a) (Tip crr mx dx) + + | n == 0 = + join + (indexByteArray arr 0) t + w (singleton_ step w s a) + + | otherwise = + let !(# !brr, !crr #) = splitByteArray 0 n arr + in Tip brr Nothing $ + join + (indexByteArray crr 0) (Tip crr mx dx) + v (singleton_ step v z a) + + Nil -> singleton_ step w s a + + + +{-# INLINE adjust0 #-} +adjust0 :: (a -> a) -> Feed -> RadixTree a -> RadixTree a +adjust0 f (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ adjust_ f step w z t + Done -> RadixTree (fmap f mx) t + +{-# INLINE adjust1 #-} +adjust1 :: (a -> a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjust1 f (Feed1 w feed) = + feed $ \step -> adjust_ f step w + +{-# INLINE adjust_ #-} +adjust_ :: (a -> a) -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjust_ f step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> Bin p (go w s l) r + | otherwise -> Bin p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> Tip arr mx (go u z' dx) + Done -> Tip arr (fmap f mx) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> t + + | otherwise = t + + Nil -> t + + + +{-# INLINE delete0 #-} +delete0 :: Feed -> RadixTree a -> RadixTree a +delete0 (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ delete_ step w z t + Done -> RadixTree Nothing t + +{-# INLINE delete1 #-} +delete1 :: Feed1 -> Radix1Tree a -> Radix1Tree a +delete1 (Feed1 w feed) = + feed $ \step -> delete_ step w + +{-# INLINE delete_ #-} +delete_ :: (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +delete_ step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> retip arr Nothing dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> t + + | otherwise = t + + Nil -> t + + + +{-# INLINE prune0 #-} +prune0 :: Openness -> Feed -> RadixTree a -> RadixTree a +prune0 openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ prune_ openness step w z t + Done -> + let my = case openness of + Open -> mx + Closed -> Nothing + + in RadixTree my Nil + +{-# INLINE prune1 #-} +prune1 :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +prune1 openness (Feed1 w feed) = + feed $ \step -> prune_ openness step w + +{-# INLINE prune_ #-} +prune_ :: Openness -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +prune_ openness step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> + case openness of + Open -> retip arr mx Nil + Closed -> Nil + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> Nil + + | otherwise = t + + Nil -> t + + + +{-# INLINE update0 #-} +update0 :: (a -> Maybe a) -> Feed -> RadixTree a -> RadixTree a +update0 f (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ update_ f step w z t + Done -> RadixTree (f =<< mx) t + +{-# INLINE update1 #-} +update1 :: (a -> Maybe a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +update1 f (Feed1 w feed) = + feed $ \step -> update_ f step w + +{-# INLINE update_ #-} +update_ + :: (a -> Maybe a) -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +update_ f step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> retip arr (f =<< mx) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> t + + | otherwise = t + + Nil -> t + + + +{-# INLINE alter0 #-} +alter0 :: (Maybe a -> Maybe a) -> Feed -> RadixTree a -> RadixTree a +alter0 f (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ alter_ f step w z t + Done -> RadixTree (f mx) t + +{-# INLINE alter1 #-} +alter1 :: (Maybe a -> Maybe a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +alter1 f (Feed1 w feed) = + feed $ \step -> alter_ f step w + +{-# INLINE alter_ #-} +alter_ + :: (Maybe a -> Maybe a) + -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +alter_ f step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> case f Nothing of + Nothing -> t + Just a -> join + w (singleton_ step w s a) + p t + + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> retip arr (f mx) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> + case f Nothing of + Nothing -> t + Just a -> + let !(# !brr, !crr #) = splitByteArray 0 (n + 1) arr + in Tip brr (Just a) (Tip crr mx dx) + + | otherwise = + case f Nothing of + Nothing -> t + Just a -> + if n == 0 + then join + (indexByteArray arr 0) (Tip arr mx dx) + w (singleton_ step v z a) + + else let !(# !brr, !crr #) = splitByteArray 0 n arr + in Tip brr Nothing $ + join + (indexByteArray crr 0) (Tip crr mx dx) + v (singleton_ step v z a) + + Nil -> + case f Nothing of + Nothing -> t + Just a -> singleton_ step w s a + + + +{-# INLINE shape0 #-} +shape0 :: (RadixTree a -> RadixTree a) -> Feed -> RadixTree a -> RadixTree a +shape0 f (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ shape_ f step w z t + Done -> f t0 + +{-# INLINE shape1 #-} +shape1 :: (RadixTree a -> RadixTree a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +shape1 f (Feed1 w feed) = + feed $ \step -> shape_ f step w + +{-# INLINE shape_ #-} +shape_ + :: (RadixTree a -> RadixTree a) + -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +shape_ f step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> let !(RadixTree my dy) = f (RadixTree Nothing Nil) + in case retip (fromStep step w s) my dy of + Nil -> t + dz -> join + w dz + p t + + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + let n' = n + 1 + in if n' >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> let !(RadixTree my dy) = f (RadixTree mx dx) + in retip arr my dy + + else case step z of + More u z' -> goarr u z' n' + Done -> + let !(# !brr, !crr #) = splitByteArray 0 n' arr + + !(RadixTree my dy) = f (RadixTree Nothing (Tip crr mx dx)) + + in retip brr my dy + + | otherwise = + let !(RadixTree my dy) = f (RadixTree Nothing Nil) + in case retip (fromStep step v z) my dy of + Nil -> t + dz -> + if n == 0 + then join + (indexByteArray arr 0) (Tip arr mx dx) + v dz + + else let !(# !brr, !crr #) = splitByteArray 0 n arr + in Tip brr Nothing $ + join + (indexByteArray crr 0) (Tip crr mx dx) + v dz + + Nil -> + let !(RadixTree my dy) = f (RadixTree Nothing Nil) + in retip (fromStep step w s) my dy + + + +{-# INLINE splitL0 #-} +splitL0 :: Openness -> Feed -> RadixTree a -> (RadixTree a, RadixTree a) +splitL0 openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + let !(# l, r #) = splitL_ openness step w z t + in (RadixTree mx l, RadixTree Nothing r) + + Done -> + let !(# my, mz #) = case openness of + Open -> (# Nothing, mx #) + Closed -> (# mx, Nothing #) + + in (RadixTree my Nil, RadixTree mz t) + +{-# INLINE splitL1 #-} +splitL1 :: Openness -> Feed1 -> Radix1Tree a -> (Radix1Tree a, Radix1Tree a) +splitL1 openness (Feed1 w feed) = \t -> + feed $ \step s -> + case splitL_ openness step w s t of + (# l, r #) -> (l, r) + +{-# INLINE splitL_ #-} +splitL_ + :: Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> (# Radix1Tree a, Radix1Tree a #) +splitL_ openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let !(# ll, lr #) = go w s l + in (# ll, rebinL p lr r #) + + else (# Nil, t #) + + else if w <= upper p + then let !(# rl, rr #) = go w s r + in (# rebinR p l rl, rr #) + + else (# t, Nil #) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> + let !(# dl, dr #) = go u z' dx + in (# retip arr mx dl, retip arr Nothing dr #) + + Done -> + let !(# my, mz #) = + case openness of + Open -> (# Nil , mx #) + Closed -> (# retip arr mx Nil, Nothing #) + + in (# my, retip arr mz dx #) + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> (# Nil, t #) + + LT -> (# t, Nil #) + + GT -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + + + +{-# INLINE splitLookup0 #-} +splitLookup0 :: Feed -> RadixTree a -> (RadixTree a, Maybe a, RadixTree a) +splitLookup0 (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + let !(# l, my, r #) = splitLookup_ step w z t + in (RadixTree mx l, my, RadixTree Nothing r) + + Done -> (RadixTree Nothing Nil, mx, RadixTree Nothing t) + +{-# INLINE splitLookup1 #-} +splitLookup1 :: Feed1 -> Radix1Tree a -> (Radix1Tree a, Maybe a, Radix1Tree a) +splitLookup1 (Feed1 w feed) = \t -> + feed $ \step s -> + case splitLookup_ step w s t of + (# l, mx, r #) -> (l, mx, r) + +{-# INLINE splitLookup_ #-} +splitLookup_ + :: (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> (# Radix1Tree a, Maybe a, Radix1Tree a #) +splitLookup_ step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let !(# ll, my, lr #) = go w s l + in (# ll, my, rebinL p lr r #) + + else (# Nil, Nothing, t #) + + else if w <= upper p + then let !(# rl, my, rr #) = go w s r + in (# rebinR p l rl, my, rr #) + + else (# t, Nothing, Nil #) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> + let !(# dl, my, dr #) = go u z' dx + in (# retip arr mx dl, my, retip arr Nothing dr #) + + Done -> + (# Nil, mx, retip arr Nothing dx #) + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> (# Nil, Nothing, t #) + + LT -> (# t, Nothing, Nil #) + + GT -> (# Nil, Nothing, t #) + + Nil -> (# Nil, Nothing, Nil #) + + + +{-# INLINE filterMaybe #-} +filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a +filterMaybe f mx = + case mx of + Just x | f x -> Just x + _ -> Nothing + +filter0 :: (a -> Bool) -> RadixTree a -> RadixTree a +filter0 f (RadixTree mx t) = RadixTree (filterMaybe f mx) (filter1 f t) + +filter1 :: (a -> Bool) -> Radix1Tree a -> Radix1Tree a +filter1 f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + Tip arr mx dx -> retip arr (filterMaybe f mx) (go dx) + Nil -> Nil + + + +filterWithKey0 :: (Build -> a -> Bool) -> RadixTree a -> RadixTree a +filterWithKey0 f (RadixTree mx t) = + RadixTree (filterMaybe (f (Build Lin)) mx) $ + filterWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +filterWithKey1 :: (Build1 -> a -> Bool) -> Radix1Tree a -> Radix1Tree a +filterWithKey1 f = filterWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE filterWithKey_ #-} +filterWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Bool) -> Radix1Tree a -> Radix1Tree a +filterWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> rebin p (go b l) (go b r) + + Tip arr mx dx -> retip arr (filterMaybe (f b arr) mx) (go (Snoc b arr) dx) + + Nil -> Nil + + + +mapMaybe0 :: (a -> Maybe b) -> RadixTree a -> RadixTree b +mapMaybe0 f (RadixTree mx t) = RadixTree (f =<< mx) (mapMaybe1 f t) + +mapMaybe1 :: (a -> Maybe b) -> Radix1Tree a -> Radix1Tree b +mapMaybe1 f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + Tip arr mx dx -> retip arr (f =<< mx) (go dx) + Nil -> Nil + + + +mapMaybeWithKey0 :: (Build -> a -> Maybe b) -> RadixTree a -> RadixTree b +mapMaybeWithKey0 f (RadixTree mx t) = + RadixTree (f (Build Lin) =<< mx) $ + mapMaybeWithKey_ (\b arr -> f (Build $ Snoc b arr)) Lin t + +mapMaybeWithKey1 :: (Build1 -> a -> Maybe b) -> Radix1Tree a -> Radix1Tree b +mapMaybeWithKey1 f = mapMaybeWithKey_ (\b arr -> f (Build1 $ b :/ arr)) Lin + +{-# INLINE mapMaybeWithKey_ #-} +mapMaybeWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe b) -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b +mapMaybeWithKey_ f = go + where + go b t = + case t of + Bin p l r -> rebin p (go b l) (go b r) + + Tip arr mx dx -> retip arr (f b arr =<< mx) (go (Snoc b arr) dx) + + Nil -> Nil + + + +partition0 :: (a -> Bool) -> RadixTree a -> (RadixTree a, RadixTree a) +partition0 f = \(RadixTree mx t) -> + let !(# l, r #) = partition_ f t + + !(# my, mz #) = + case mx of + Just x + | f x -> (# mx , Nothing #) + | otherwise -> (# Nothing, mx #) + + Nothing -> (# Nothing, Nothing #) + + in (RadixTree my l, RadixTree mz r) + +partition1 :: (a -> Bool) -> Radix1Tree a -> (Radix1Tree a, Radix1Tree a) +partition1 f = \t -> + case partition_ f t of + (# l, r #) -> (l, r) + +partition_ :: (a -> Bool) -> Radix1Tree a -> (# Radix1Tree a, Radix1Tree a #) +partition_ f = go + where + go t = + case t of + Bin p l r -> + let !(# ly, lz #) = go l + !(# ry, rz #) = go r + + in (# rebin p ly ry, rebin p lz rz #) + + Tip arr mx dx -> + let !(# dy, dz #) = go dx + in case mx of + Nothing -> (# retip arr Nothing dy, retip arr Nothing dz #) + Just x -> + if f x + then (# Tip arr (Just x) dy, retip arr Nothing dz #) + else (# retip arr Nothing dy, Tip arr (Just x) dz #) + + Nil -> (# Nil, Nil #) + + + +partitionWithKey0 :: (Build -> a -> Bool) -> RadixTree a -> (RadixTree a, RadixTree a) +partitionWithKey0 f = \(RadixTree mx t) -> + let !(# l, r #) = partitionWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + + !(# my, mz #) = + case mx of + Just x + | f (Build Lin) x -> (# mx , Nothing #) + | otherwise -> (# Nothing, mx #) + + Nothing -> (# Nothing, Nothing #) + + in (RadixTree my l, RadixTree mz r) + +partitionWithKey1 :: (Build1 -> a -> Bool) -> Radix1Tree a -> (Radix1Tree a, Radix1Tree a) +partitionWithKey1 f = \t -> + case partitionWithKey_ (\b arr -> f (Build1 $ b :/ arr)) t of + (# !l, !r #) -> (l, r) + +{-# INLINE partitionWithKey_ #-} +partitionWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Bool) + -> Radix1Tree a -> (# Radix1Tree a, Radix1Tree a #) +partitionWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> + let !(# ly, lz #) = go b l + !(# ry, rz #) = go b r + + in (# rebin p ly ry, rebin p lz rz #) + + Tip arr mx dx -> + let !(# dy, dz #) = go (Snoc b arr) dx + in case mx of + Nothing -> (# retip arr Nothing dy, retip arr Nothing dz #) + Just x -> + if f b arr x + then (# Tip arr (Just x) dy, retip arr Nothing dz #) + else (# retip arr Nothing dy, Tip arr (Just x) dz #) + + Nil -> (# Nil, Nil #) + + + +mapEither0 :: (a -> Either b c) -> RadixTree a -> (RadixTree b, RadixTree c) +mapEither0 f = \(RadixTree mx t) -> + let !(# l, r #) = mapEither_ f t + + !(# my, mz #) = + case mx of + Just x -> + case f x of + Left y -> (# Just y , Nothing #) + Right z -> (# Nothing, Just z #) + + Nothing -> (# Nothing, Nothing #) + + in (RadixTree my l, RadixTree mz r) + +mapEither1 :: (a -> Either b c) -> Radix1Tree a -> (Radix1Tree b, Radix1Tree c) +mapEither1 f = \t -> + case mapEither_ f t of + (# l, r #) -> (l, r) + +mapEither_ :: (a -> Either b c) -> Radix1Tree a -> (# Radix1Tree b, Radix1Tree c #) +mapEither_ f = go + where + go t = + case t of + Bin p l r -> + let !(# ly, lz #) = go l + !(# ry, rz #) = go r + + in (# rebin p ly ry, rebin p lz rz #) + + Tip arr mx dx -> + let !(# dy, dz #) = go dx + in case mx of + Nothing -> (# retip arr Nothing dy, retip arr Nothing dz #) + Just x -> + case f x of + Left y -> (# Tip arr (Just y) dy, retip arr Nothing dz #) + Right z -> (# retip arr Nothing dy, Tip arr (Just z) dz #) + + Nil -> (# Nil, Nil #) + + + +mapEitherWithKey0 + :: (Build -> a -> Either b c) -> RadixTree a -> (RadixTree b, RadixTree c) +mapEitherWithKey0 f = \(RadixTree mx t) -> + let !(# l, r #) = mapEitherWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + + !(# my, mz #) = + case mx of + Just x -> + case f (Build Lin) x of + Left y -> (# Just y , Nothing #) + Right z -> (# Nothing, Just z #) + + Nothing -> (# Nothing, Nothing #) + + in (RadixTree my l, RadixTree mz r) + +mapEitherWithKey1 + :: (Build1 -> a -> Either b c) -> Radix1Tree a -> (Radix1Tree b, Radix1Tree c) +mapEitherWithKey1 f = \t -> + case mapEitherWithKey_ (\b arr -> f (Build1 $ b :/ arr)) t of + (# l, r #) -> (l, r) + +{-# INLINE mapEitherWithKey_ #-} +mapEitherWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Either b c) + -> Radix1Tree a -> (# Radix1Tree b, Radix1Tree c #) +mapEitherWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> + let !(# ly, lz #) = go b l + !(# ry, rz #) = go b r + + in (# rebin p ly ry, rebin p lz rz #) + + Tip arr mx dx -> + let !(# dy, dz #) = go (Snoc b arr) dx + in case mx of + Nothing -> (# retip arr Nothing dy, retip arr Nothing dz #) + Just x -> + case f b arr x of + Left y -> (# Tip arr (Just y) dy, retip arr Nothing dz #) + Right z -> (# retip arr Nothing dy, Tip arr (Just z) dz #) + + Nil -> (# Nil, Nil #) + + + +moduleLoc1 :: String +moduleLoc1 = "Radix1Tree.Word8.Lazy" + + + +lookupMin0 :: RadixTree a -> Maybe a +lookupMin0 (RadixTree mx t) = + case mx of + Just x -> Just x + Nothing -> lookupMin1 t + +lookupMin1 :: Radix1Tree a -> Maybe a +lookupMin1 Nil = Nothing +lookupMin1 t = let !(# a #) = unsafeLookupMin1 t + in Just a + +unsafeLookupMin1 :: Radix1Tree a -> (# a #) +unsafeLookupMin1 t = + case t of + Bin _ l _ -> unsafeLookupMin1 l + Tip _ mx dx -> case mx of + Just x -> (# x #) + Nothing -> unsafeLookupMin1 dx + + Nil -> throw $ MalformedTree moduleLoc1 "lookupMin" + + + +lookupMinWithKey0 :: RadixTree a -> Maybe (Lookup a) +lookupMinWithKey0 (RadixTree mx t) = + case mx of + Just x -> Just (Lookup (Build Lin) x) + Nothing -> + case t of + Nil -> Nothing + _ -> let !(# b, arr, a #) = unsafeLookupMinWithKey_ Lin t + in Just $! Lookup (Build $ Snoc b arr) a + +lookupMinWithKey1 :: Radix1Tree a -> Maybe (Lookup1 a) +lookupMinWithKey1 Nil = Nothing +lookupMinWithKey1 t = Just $! unsafeLookupMinWithKey1 t + +unsafeLookupMinWithKey1 :: Radix1Tree a -> Lookup1 a +unsafeLookupMinWithKey1 t = + let !(# b, arr, a #) = unsafeLookupMinWithKey_ Lin t + in Lookup1 (Build1 $ b :/ arr) a + +unsafeLookupMinWithKey_ + :: Tsil ByteArray -> Radix1Tree a -> (# Tsil ByteArray, ByteArray, a #) +unsafeLookupMinWithKey_ = go + where + go b t = + case t of + Bin _ l _ -> go b l + Tip arr mx dx -> case mx of + Just x -> (# b, arr, x #) + Nothing -> go (Snoc b arr) dx + + Nil -> throw $ MalformedTree moduleLoc1 "lookupMinWithKey" + + + +lookupMax0 :: RadixTree a -> Maybe a +lookupMax0 (RadixTree mx t) = + case t of + Nil -> mx + _ -> let !(# a #) = unsafeLookupMax1 t + in Just a + +lookupMax1 :: Radix1Tree a -> Maybe a +lookupMax1 Nil = Nothing +lookupMax1 t = let !(# a #) = unsafeLookupMax1 t + in Just a + +unsafeLookupMax1 :: Radix1Tree a -> (# a #) +unsafeLookupMax1 t = + case t of + Bin _ _ r -> unsafeLookupMax1 r + Tip _ mx dx -> case dx of + Nil | Just x <- mx -> (# x #) + _ -> unsafeLookupMax1 dx + + Nil -> throw $ MalformedTree moduleLoc1 "lookupMin" + + + +lookupMaxWithKey0 :: RadixTree a -> Maybe (Lookup a) +lookupMaxWithKey0 (RadixTree mx t) = + case t of + Nil -> Lookup (Build Lin) `fmap'` mx + _ -> let !(# b, arr, a #) = unsafeLookupMaxWithKey_ Lin t + in Just $! Lookup (Build $ Snoc b arr) a + +lookupMaxWithKey1 :: Radix1Tree a -> Maybe (Lookup1 a) +lookupMaxWithKey1 Nil = Nothing +lookupMaxWithKey1 t = Just $! unsafeLookupMaxWithKey1 t + +unsafeLookupMaxWithKey1 :: Radix1Tree a -> Lookup1 a +unsafeLookupMaxWithKey1 t = + let !(# b, arr, a #) = unsafeLookupMaxWithKey_ Lin t + in Lookup1 (Build1 $ b :/ arr) a + +unsafeLookupMaxWithKey_ + :: Tsil ByteArray -> Radix1Tree a -> (# Tsil ByteArray, ByteArray, a #) +unsafeLookupMaxWithKey_ = go + where + go b t = + case t of + Bin _ _ r -> go b r + Tip arr mx dx -> case dx of + Nil | Just x <- mx -> (# b, arr, x #) + _ -> go (Snoc b arr) dx + + Nil -> throw $ MalformedTree moduleLoc1 "lookupMaxWithKey" + + + +deleteMin0 :: RadixTree a -> RadixTree a +deleteMin0 (RadixTree mx t) = + case mx of + Just _ -> RadixTree Nothing t + Nothing -> RadixTree mx (deleteMin1 t) + +deleteMin1 :: Radix1Tree a -> Radix1Tree a +deleteMin1 Nil = Nil +deleteMin1 r = unsafeDeleteMin1 r + +unsafeDeleteMin1 :: Radix1Tree a -> Radix1Tree a +unsafeDeleteMin1 = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + + Tip arr mx dx -> case mx of + Nothing -> retip arr mx (go dx) + Just _ -> retip arr Nothing dx + + Nil -> Nil + + + +deleteMax0 :: RadixTree a -> RadixTree a +deleteMax0 t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just _ -> RadixTree Nothing t + Nothing -> t0 + + _ -> RadixTree mx (unsafeDeleteMax1 t) + +deleteMax1 :: Radix1Tree a -> Radix1Tree a +deleteMax1 Nil = Nil +deleteMax1 r = unsafeDeleteMax1 r + +unsafeDeleteMax1 :: Radix1Tree a -> Radix1Tree a +unsafeDeleteMax1 = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + + Tip arr mx dx -> case dx of + Nil -> Nil + _ -> retip arr mx (go dx) + + Nil -> Nil + + + +adjustMin0 :: (a -> a) -> RadixTree a -> RadixTree a +adjustMin0 f (RadixTree mx t) = + case mx of + Just x -> RadixTree (Just $ f x) t + Nothing -> RadixTree mx (adjustMin1 f t) + +adjustMin1 :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMin1 _ Nil = Nil +adjustMin1 f r = unsafeAdjustMin1 f r + +unsafeAdjustMin1 :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMin1 f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) r + + Tip arr mx dx -> case mx of + Just x -> Tip arr (Just $ f x) dx + Nothing -> Tip arr mx (go dx) + + Nil -> Nil + + + +adjustMinWithKey0 :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMinWithKey0 f (RadixTree mx t) = + case mx of + Just x -> RadixTree (Just $ f (Build Lin) x) t + Nothing -> RadixTree mx $ + case t of + Nil -> Nil + _ -> unsafeAdjustMinWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +adjustMinWithKey1 :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMinWithKey1 _ Nil = Nil +adjustMinWithKey1 f r = unsafeAdjustMinWithKey1 f r + +unsafeAdjustMinWithKey1 :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMinWithKey1 f = unsafeAdjustMinWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeAdjustMinWithKey_ #-} +unsafeAdjustMinWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMinWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> Bin p (go b l) r + + Tip arr mx dx -> case mx of + Just x -> Tip arr (Just $ f b arr x) dx + Nothing -> Tip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +adjustMax0 :: (a -> a) -> RadixTree a -> RadixTree a +adjustMax0 f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (Just $ f x) t + Nothing -> t0 + + _ -> RadixTree mx (unsafeAdjustMax1 f t) + +adjustMax1 :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMax1 _ Nil = Nil +adjustMax1 f r = unsafeAdjustMax1 f r + +unsafeAdjustMax1 :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMax1 f = go + where + go t = + case t of + Bin p l r -> Bin p l (go r) + + Tip arr mx dx -> case dx of + Nil | Just x <- mx -> Tip arr (Just $ f x) dx + _ -> Tip arr mx (go dx) + + Nil -> Nil + + + +adjustMaxWithKey0 :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMaxWithKey0 f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (Just $ f (Build Lin) x) t + Nothing -> t0 + + _ -> RadixTree mx $ + unsafeAdjustMaxWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +adjustMaxWithKey1 :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMaxWithKey1 _ Nil = Nil +adjustMaxWithKey1 f r = unsafeAdjustMaxWithKey1 f r + +unsafeAdjustMaxWithKey1 :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMaxWithKey1 f = unsafeAdjustMaxWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeAdjustMaxWithKey_ #-} +unsafeAdjustMaxWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMaxWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> Bin p l (go b r) + + Tip arr mx dx -> + case dx of + Nil | Just x <- mx -> Tip arr (Just $ f b arr x) dx + _ -> Tip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +updateMin0 :: (a -> Maybe a) -> RadixTree a -> RadixTree a +updateMin0 f (RadixTree mx t) = + case mx of + Just x -> RadixTree (f x) t + Nothing -> RadixTree mx (updateMin1 f t) + +updateMin1 :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMin1 _ Nil = Nil +updateMin1 f r = unsafeUpdateMin1 f r + +unsafeUpdateMin1 :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMin1 f = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + + Tip arr mx dx -> case mx of + Just x -> retip arr (f x) dx + Nothing -> retip arr mx (go dx) + + Nil -> Nil + + + +updateMinWithKey0 :: (Build -> a -> Maybe a) -> RadixTree a -> RadixTree a +updateMinWithKey0 f (RadixTree mx t) = + case mx of + Just x -> RadixTree (f (Build Lin) x) t + Nothing -> RadixTree mx $ + case t of + Nil -> Nil + _ -> unsafeUpdateMinWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +updateMinWithKey1 :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMinWithKey1 _ Nil = Nil +updateMinWithKey1 f r = unsafeUpdateMinWithKey1 f r + +unsafeUpdateMinWithKey1 :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMinWithKey1 f = unsafeUpdateMinWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeUpdateMinWithKey_ #-} +unsafeUpdateMinWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMinWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> rebinL p (go b l) r + + Tip arr mx dx -> case mx of + Just x -> retip arr (f b arr x) dx + Nothing -> retip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +updateMax0 :: (a -> Maybe a) -> RadixTree a -> RadixTree a +updateMax0 f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (f x) t + Nothing -> t0 + + _ -> RadixTree mx (unsafeUpdateMax1 f t) + +updateMax1 :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMax1 _ Nil = Nil +updateMax1 f r = unsafeUpdateMax1 f r + +unsafeUpdateMax1 :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMax1 f = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + + Tip arr mx dx -> case dx of + Nil | Just x <- mx -> retip arr (f x) dx + _ -> retip arr mx (go dx) + + Nil -> Nil + + + +updateMaxWithKey0 :: (Build -> a -> Maybe a) -> RadixTree a -> RadixTree a +updateMaxWithKey0 f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (f (Build Lin) x) t + Nothing -> t0 + + _ -> RadixTree mx $ + unsafeUpdateMaxWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +updateMaxWithKey1 :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMaxWithKey1 _ Nil = Nil +updateMaxWithKey1 f r = unsafeUpdateMaxWithKey1 f r + +unsafeUpdateMaxWithKey1 :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMaxWithKey1 f = unsafeUpdateMaxWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeUpdateMaxWithKey_ #-} +unsafeUpdateMaxWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMaxWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> rebinR p l (go b r) + + Tip arr mx dx -> case dx of + Nil | Just x <- mx -> retip arr (f b arr x) dx + _ -> retip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +-- | The leftmost value with its key and the rest of the tree. +data ViewL a = ViewL !Build a !(RadixTree a) + deriving Show + +minView0 :: RadixTree a -> Maybe (ViewL a) +minView0 (RadixTree mx t) = + case mx of + Just x -> Just $! ViewL (Build Lin) x (RadixTree Nothing t) + Nothing -> + case t of + Nil -> Nothing + _ -> Just $! let !(# !b, !arr, x, !t' #) = unsafeMinView_ t + in ViewL (Build $ Snoc b arr) x (RadixTree mx t') + + +-- | The leftmost value with its key and the rest of the tree. +data ViewL1 a = ViewL1 !Build1 a !(Radix1Tree a) + deriving Show + +minView1 :: Radix1Tree a -> Maybe (ViewL1 a) +minView1 Nil = Nothing +minView1 t = Just $! unsafeMinView1 t + +unsafeMinView1 :: Radix1Tree a -> ViewL1 a +unsafeMinView1 t = + let !(# !b, !arr, x, !t' #) = unsafeMinView_ t + in ViewL1 (Build1 $ b :/ arr) x t' + +unsafeMinView_ :: Radix1Tree a -> (# Tsil ByteArray, ByteArray, a, Radix1Tree a #) +unsafeMinView_ = go Lin + where + go b t = + case t of + Bin p l r -> + let !(# !b', !brr, z, !l' #) = go b l + in (# b', brr, z, rebinL p l' r #) + + Tip arr mx dx -> + case mx of + Just x -> (# b, arr, x, retip arr Nothing dx #) + Nothing -> + let !(# !b', !brr, z, !dy #) = go (Snoc b arr) dx + in (# b', brr, z, retip arr mx dy #) + + Nil -> throw $ MalformedTree moduleLoc1 "minView" + + + +-- | The rightmost value with its key and the rest of the tree. +data ViewR a = ViewR !(RadixTree a) !Build a + deriving Show + +maxView0 :: RadixTree a -> Maybe (ViewR a) +maxView0 (RadixTree mx t) = + case t of + Nil -> ViewR (RadixTree Nothing t) (Build Lin) `fmap'` mx + _ -> Just $! let !(# !t', !b, !arr, x #) = unsafeMaxView_ t + in ViewR (RadixTree mx t') (Build $ Snoc b arr) x + + +-- | The rightmost value with its key and the rest of the tree. +data ViewR1 a = ViewR1 !(Radix1Tree a) !Build1 a + deriving Show + +maxView1 :: Radix1Tree a -> Maybe (ViewR1 a) +maxView1 Nil = Nothing +maxView1 t = Just $! unsafeMaxView1 t + +unsafeMaxView1 :: Radix1Tree a -> ViewR1 a +unsafeMaxView1 t = + let !(# !t', !b, !arr, x #) = unsafeMaxView_ t + in ViewR1 t' (Build1 $ b :/ arr) x + +unsafeMaxView_ :: Radix1Tree a -> (# Radix1Tree a, Tsil ByteArray, ByteArray, a #) +unsafeMaxView_ = go Lin + where + go b t = + case t of + Bin p l r -> + let !(# !r', !b', !brr, z #) = go b r + in (# rebinR p l r', b', brr, z #) + + Tip arr mx dx -> + case dx of + Nil | Just x <- mx -> (# retip arr Nothing dx, b, arr, x #) + _ -> + let !(# !dy, !b', !brr, z #) = go (Snoc b arr) dx + in (# retip arr mx dy, b', brr, z #) + + Nil -> throw $ MalformedTree moduleLoc1 "maxView" diff --git a/src/Data/RadixNTree/Word8/Lazy/Debug.hs b/src/Data/RadixNTree/Word8/Lazy/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Lazy/Debug.hs @@ -0,0 +1,109 @@ +module Data.RadixNTree.Word8.Lazy.Debug + ( showsTree0 + , showsTree1 + + , Validity (..) + , Reason (..) + , validate0 + , validate1 + ) where + +import Data.ByteArray.NonEmpty +import Data.RadixNTree.Word8.Debug +import Data.RadixNTree.Word8.Key +import Data.RadixNTree.Word8.Lazy +import Numeric.Long +import Radix.Word8.Debug + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Primitive.ByteArray + + + +showsTree0 :: (a -> ShowS) -> RadixTree a -> ShowS +showsTree0 f (RadixTree mx t) = + showString "RadixTree" . case mx of + Just x -> showString " => " . f x + Nothing -> id + + . showChar '\n' + + . showsTree_ 2 f t + +showsTree1 :: (a -> ShowS) -> Radix1Tree a -> ShowS +showsTree1 f = showsTree_ 0 f + +showsTree_ :: Int -> (a -> ShowS) -> Radix1Tree a -> ShowS +showsTree_ n0 f = go n0 + where + go i t = + mappend (replicate i ' ') . + case t of + Bin p l r -> + showString "Bin " . showPrefix p . showChar '\n' + . go (i + 2) l . showChar '\n' + . go (i + 2) r + + Tip arr mx dx -> + showString "Tip " . if sizeofByteArray arr <= 0 + then id + else let w0 :| ws = toNonEmpty arr + in showLongBin w0 + . showString " (" . showLongHex w0 . showChar ')' + . foldr (\x s -> showChar ' ' . showLongHex x . s) id ws + + . case mx of + Just x -> showString " => " . f x + Nothing -> id + + . showChar '\n' + + . go (i + 2) dx + + Nil -> showString "Nil" + + + +validate0 :: RadixTree a -> Validity +validate0 (RadixTree _ t) = validate1 t + +validate1 :: Radix1Tree a -> Validity +validate1 = go Lin + where + go b t = + case t of + Bin p l r + | p == 0 -> Invalid (Build b) ZeroPrefix + | 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 + | Nothing <- mx, Tip _ _ _ <- dx -> Invalid (Build b) UncompressedTip + | Nothing <- mx, Nil <- dx -> Invalid (Build b) UncompressedTip + | otherwise -> go (Snoc b arr) dx + + Nil -> Valid + + 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 -> + 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) -> + Invalid (Build b) $ KeyBelow q (indexByteArray arr 0) + + | Nothing <- mx, Tip _ _ _ <- dx -> Invalid (Build b) UncompressedTip + | Nothing <- mx, Nil <- dx -> Invalid (Build b) UncompressedTip + | otherwise -> go (Snoc b arr) dx + + Nil -> Invalid (Build b) $ MalformedBin q diff --git a/src/Data/RadixNTree/Word8/Lazy/TH.hs b/src/Data/RadixNTree/Word8/Lazy/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Lazy/TH.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Data.RadixNTree.Word8.Lazy.TH + ( RadixTree + , sequenceCode0 + + , Radix1Tree + , sequenceCode1 + ) where + +import Data.RadixNTree.Word8.Lazy + +import Language.Haskell.TH.Syntax + + + +sequenceCode0 :: Quote m => RadixTree (Code m a) -> Code m (RadixTree a) +sequenceCode0 (RadixTree mx t) = + [|| RadixTree $$(sequenceMaybe mx) $$(sequenceCode1 t) ||] + +sequenceCode1 :: Quote m => Radix1Tree (Code m a) -> Code m (Radix1Tree a) +sequenceCode1 t = + case t of + Bin p l r -> + [|| Bin + p + $$(sequenceCode1 l) + $$(sequenceCode1 r) + ||] + + Tip arr mx dx -> [|| Tip arr $$(sequenceMaybe mx) $$(sequenceCode1 dx) ||] + + Nil -> [|| Nil ||] + + + +sequenceMaybe :: Quote m => Maybe (Code m a) -> Code m (Maybe a) +sequenceMaybe mx = + case mx of + Just x -> [|| Just $$(x) ||] + Nothing -> [|| Nothing ||] diff --git a/src/Data/RadixNTree/Word8/Strict.hs b/src/Data/RadixNTree/Word8/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Strict.hs @@ -0,0 +1,5643 @@ +{-# LANGUAGE BangPatterns + , GADTs + , RankNTypes + , ScopedTypeVariables + , UnboxedTuples #-} + +module Data.RadixNTree.Word8.Strict + ( StrictRadixTree + , RadixTree (..) + + , StrictRadix1Tree + , Radix1Tree (..) + + , empty0 + , empty1 + + , singleton0 + , singleton1 + + , map0 + , map0' + , mapWithKey0 + , mapWithKey0' + + , map1 + , map1' + , mapWithKey1 + , mapWithKey1' + + , foldl0 + , foldl0' + , foldlWithKey0 + , foldlWithKey0' + + , Data.RadixNTree.Word8.Strict.foldl1 + , foldl1' + , foldlWithKey1 + , foldlWithKey1' + + , foldr0 + , foldr0' + , foldrWithKey0 + , foldrWithKey0' + + , Data.RadixNTree.Word8.Strict.foldr1 + , foldr1' + , foldrWithKey1 + , foldrWithKey1' + + , foldMap0 + , foldMapWithKey0 + + , foldMap1 + , foldMapWithKey1 + + , traverse0 + , traverseWithKey0 + + , traverse1 + , traverseWithKey1 + + , null0 + , null1 + + , size0 + , size1 + + , lookup0 + , find0 + , member0 + , subtree0 + , prefix0 + + , lookup1 + , find1 + , member1 + , subtree1 + , prefix1 + + , Point (..) + , Cursor (..) + , stop + + , Location (..) + , locate + + , cursor0 + , move0 + + , cursor1 + , move1 + + , lookupL0 + , lookupL1 + + , lookupR0 + , lookupR1 + + , adjustL0 + , adjustL0' + , adjustLWithKey0 + , adjustLWithKey0' + + , adjustL1 + , adjustL1' + , adjustLWithKey1 + , adjustLWithKey1' + + , adjustR0 + , adjustR0' + , adjustRWithKey0 + , adjustRWithKey0' + + , adjustR1 + , adjustR1' + , adjustRWithKey1 + , adjustRWithKey1' + + , updateL0 + , updateLWithKey0 + + , updateL1 + , updateLWithKey1 + + , updateR0 + , updateRWithKey0 + + , updateR1 + , updateRWithKey1 + + , takeL0 + , takeL1 + + , takeR0 + , takeR1 + + , union0 + , union1 + + , unionL0 + , unionL1 + + , unionWith0' + , unionWith1' + + , unionWithKey0' + , unionWithKey1' + + , difference0 + , difference1 + + , differenceWith0 + , differenceWith1 + + , differenceWithKey0 + , differenceWithKey1 + + , compare0 + , Data.RadixNTree.Word8.Strict.compare1 + + , disjoint0 + , disjoint1 + + , intersection0 + , intersection1 + + , intersectionL0 + , intersectionL1 + + , intersectionWith0' + , intersectionWith1' + + , intersectionWithKey0' + , intersectionWithKey1' + + , merge0 + , merge1 + + , insert0 + , insert1 + + , insertWith0 + , insertWith0' + + , insertWith1 + , insertWith1' + + , adjust0 + , adjust0' + + , adjust1 + , adjust1' + + , delete0 + , delete1 + + , prune0 + , prune1 + + , update0 + , update1 + + , alter0 + , alter1 + + , shape0 + , shape1 + + , Split (..) + , Split1 (..) + , splitL0 + , splitL1 + + , SplitLookup (..) + , SplitLookup1 (..) + , splitLookup0 + , splitLookup1 + + , filter0 + , filterWithKey0 + + , filter1 + , filterWithKey1 + + , mapMaybe0 + , mapMaybeWithKey0 + + , mapMaybe1 + , mapMaybeWithKey1 + + , partition0 + , partitionWithKey0 + + , partition1 + , partitionWithKey1 + + , mapEither0 + , mapEitherWithKey0 + + , mapEither1 + , mapEitherWithKey1 + + , lookupMin0 + , lookupMin1 + , unsafeLookupMin1 + + , lookupMinWithKey0 + , lookupMinWithKey1 + , unsafeLookupMinWithKey1 + + , lookupMax0 + , lookupMax1 + , unsafeLookupMax1 + + , lookupMaxWithKey0 + , lookupMaxWithKey1 + , unsafeLookupMaxWithKey1 + + , deleteMin0 + , deleteMin1 + , unsafeDeleteMin1 + + , deleteMax0 + , deleteMax1 + , unsafeDeleteMax1 + + , adjustMin0 + , adjustMin1 + , unsafeAdjustMin1 + + , adjustMin0' + , adjustMin1' + , unsafeAdjustMin1' + + , adjustMinWithKey0 + , adjustMinWithKey1 + , unsafeAdjustMinWithKey1 + + , adjustMinWithKey0' + , adjustMinWithKey1' + , unsafeAdjustMinWithKey1' + + , adjustMax0 + , adjustMax1 + , unsafeAdjustMax1 + + , adjustMax0' + , adjustMax1' + , unsafeAdjustMax1' + + , adjustMaxWithKey0 + , adjustMaxWithKey1 + , unsafeAdjustMaxWithKey1 + + , adjustMaxWithKey0' + , adjustMaxWithKey1' + , unsafeAdjustMaxWithKey1' + + , updateMin0 + , updateMin1 + , unsafeUpdateMin1 + + , updateMinWithKey0 + , updateMinWithKey1 + , unsafeUpdateMinWithKey1 + + , updateMax0 + , updateMax1 + , unsafeUpdateMax1 + + , updateMaxWithKey0 + , updateMaxWithKey1 + , unsafeUpdateMaxWithKey1 + + , ViewL (..) + , ViewL1 (..) + , minView0 + , minView1 + , unsafeMinView1 + + , ViewR (..) + , ViewR1 (..) + , maxView0 + , maxView1 + , unsafeMaxView1 + ) where + +import Data.ByteArray.NonEmpty +import Data.RadixNTree.Word8.Common +import Data.RadixNTree.Word8.Key +import Radix.Common +import Radix.Exception +import Radix.Word8.Common +import Radix.Word8.Foundation + +import Control.Applicative +import Control.Exception (throw) +import Control.DeepSeq +import Data.Bits +import Data.Foldable +import Data.Functor.Classes +import Data.Primitive.ByteArray +import Data.Word +import Text.Show + + + +-- | Convenience type synonym. +type StrictRadixTree = RadixTree + +-- | Spine-strict radix tree with byte sequences as keys. +data RadixTree a = RadixTree + {-# UNPACK #-} !(Maybe a) -- ^ Value at the empty byte sequence key. + !(Radix1Tree a) + +instance Show a => Show (RadixTree a) where + showsPrec = liftShowsPrec showsPrec showList + +instance Show1 RadixTree where + liftShowsPrec showsPrec_ showList_ d t = + showParen (d > 10) $ + showListWith (liftShowsPrec showsPrec_ showList_ 0) $ + foldrWithKey0 (\k a -> (:) (k, a)) [] t + +instance Eq a => Eq (RadixTree a) where + (==) = liftEq (==) + +instance Eq1 RadixTree where + liftEq eq (RadixTree mx l) (RadixTree my r) = liftEq eq mx my && liftEq eq l r + +-- | Uses 'Data.RadixTree.Word8.Strict.map'. +instance Functor RadixTree where + fmap = map0 + +instance Foldable RadixTree where + foldl = foldl0 + foldr = foldr0 + foldMap = foldMap0 + + foldl' = foldl0' + foldr' = foldr0' + + null = null0 + + length = size0 + +instance Traversable RadixTree where + traverse = traverse0 + + +instance NFData a => NFData (RadixTree a) where + rnf = liftRnf rnf + +instance NFData1 RadixTree where + liftRnf nf (RadixTree mx t) = liftRnf nf mx `seq` liftRnf nf t + + + +-- | Convenience type synonym. +type StrictRadix1Tree = Radix1Tree + +-- | Spine-strict radix tree with non-empty byte sequences as keys. +data Radix1Tree a = Bin + {-# UNPACK #-} !Prefix + !(Radix1Tree a) -- ^ Masked bit is @0@. Invariant: not 'Nil'. + !(Radix1Tree a) -- ^ Masked bit is @1@. Invariant: not 'Nil'. + + | Tip + {-# UNPACK #-} !ByteArray -- ^ Invariant: non-empty. + {-# UNPACK #-} !(Maybe a) -- ^ Invariant: can only be 'Nothing' when + -- the tree below is 'Bin'. + !(Radix1Tree a) + + | Nil + +instance Show a => Show (Radix1Tree a) where + showsPrec = liftShowsPrec showsPrec showList + +instance Show1 Radix1Tree where + liftShowsPrec showsPrec_ showList_ d t = + showParen (d > 10) $ + showListWith (liftShowsPrec showsPrec_ showList_ 0) $ + foldrWithKey1 (\k a -> (:) (k, a)) [] t + +instance Eq a => Eq (Radix1Tree a) where + (==) = liftEq (==) + +instance Eq1 Radix1Tree where + liftEq eq = go + where + go l r = + case l of + Bin p xl xr -> + case r of + Bin q yl yr -> p == q && go xl yl && go xr yr + _ -> False + + Tip arr mx dx -> + case r of + Tip brr my dy -> arr == brr && liftEq eq mx my && go dx dy + _ -> False + + Nil -> + case r of + Nil -> True + _ -> False + +-- | Uses 'Data.Radix1Tree.Word8.Strict.map'. +instance Functor Radix1Tree where + fmap = map1 + +instance Foldable Radix1Tree where + foldl = Data.RadixNTree.Word8.Strict.foldl1 + foldr = Data.RadixNTree.Word8.Strict.foldr1 + foldMap = foldMap1 + + foldl' = foldl1' + foldr' = foldr1' + + null = null1 + + length = size1 + +instance Traversable Radix1Tree where + traverse = traverse1 + + +instance NFData a => NFData (Radix1Tree a) where + rnf = liftRnf rnf + +instance NFData1 Radix1Tree where + liftRnf nf = go + where + go t = + case t of + Bin _ l r -> go l `seq` go r + Tip _ mx dx -> liftRnf nf mx `seq` go dx + Nil -> () + + + +{-# INLINE join #-} +-- | Knowing that the prefices of two trees disagree, construct a 'Bin'. +join :: Prefix -> Radix1Tree a -> Prefix -> Radix1Tree a -> Radix1Tree a +join p0 t0 p1 t1 = + let m = branchingBit p0 p1 + + p = mask p0 m .|. m + + in if zeroBit p0 m + then Bin p t0 t1 + else Bin p t1 t0 + +{-# INLINE safeJoin #-} +safeJoin :: Prefix -> Radix1Tree a -> Prefix -> Radix1Tree a -> Radix1Tree a +safeJoin _ Nil _ t1 = t1 +safeJoin _ t0 _ Nil = t0 +safeJoin p0 t0 p1 t1 = join p0 t0 p1 t1 + +{-# INLINE retip #-} +-- | Based on the altered entry and/or downward state, fuse or remove the 'Tip' as needed. +retip :: ByteArray -> Maybe a -> Radix1Tree a -> Radix1Tree a +retip arr mx dx = + case mx of + Just _ -> Tip arr mx dx + Nothing -> + case dx of + Bin _ _ _ -> Tip arr mx dx + Tip brr my dy -> Tip (appendByteArray arr brr) my dy + Nil -> Nil + +{-# INLINE dropTrim #-} +dropTrim :: Int -> ByteArray -> Maybe a -> Radix1Tree a -> Radix1Tree a +dropTrim n arr mx dx = + case mx of + Just _ -> Tip (dropByteArray n arr) mx dx + Nothing -> + case dx of + Bin _ _ _ -> Tip (dropByteArray n arr) mx dx + Tip brr my dy -> Tip (dropAppendByteArray n arr brr) my dy + Nil -> Nil + + +{-# INLINE rebin #-} +rebin :: Prefix -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +rebin p l r = + case l of + Nil -> r + _ -> case r of + Nil -> l + _ -> Bin p l r + +{-# INLINE rebinL #-} +rebinL :: Prefix -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +rebinL p l r = + case l of + Nil -> r + _ -> Bin p l r + +{-# INLINE rebinR #-} +rebinR :: Prefix -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +rebinR p l r = + case r of + Nil -> l + _ -> Bin p l r + + + +empty0 :: RadixTree a +empty0 = RadixTree Nothing Nil + +empty1 :: Radix1Tree a +empty1 = Nil + + + +{-# INLINE singleton0 #-} +singleton0 :: Feed -> a -> RadixTree a +singleton0 (Feed feed) = \a -> + feed $ \step s -> + case step s of + More w z -> RadixTree Nothing $ singleton1 (Feed1 w (\g -> g step z)) a + Done -> RadixTree (Just a) Nil + +{-# INLINE singleton1 #-} +singleton1 :: Feed1 -> a -> Radix1Tree a +singleton1 (Feed1 w feed) = \a -> feed $ \step s -> singleton_ step w s a + +{-# INLINE singleton_ #-} +-- | \(\mathcal{O}(1)\). Single element radix tree. +singleton_ :: (b -> Step Word8 b) -> Word8 -> b -> a -> Radix1Tree a +singleton_ step w s = \a -> Tip (fromStep step w s) (Just a) Nil + + + +null0 :: RadixTree a -> Bool +null0 (RadixTree Nothing t) = null1 t +null0 _ = False + +null1 :: Radix1Tree a -> Bool +null1 Nil = True +null1 _ = False + + + +size0 :: RadixTree a -> Int +size0 (RadixTree mx t) = + let !n = size1 t + in case mx of + Just _ -> n + 1 + Nothing -> n + +size1 :: Radix1Tree a -> Int +size1 = go 0 + where + go z t = + case t of + Bin _ l r -> let !n = go z l + in go n r + + Tip _ mx dx -> case mx of + Nothing -> go z dx + Just _ -> let !n = go z dx + in n + 1 + Nil -> z + + + +{-# INLINE fmap' #-} +fmap' :: (a -> b) -> Maybe a -> Maybe b +fmap' f (Just x) = Just $! f x +fmap' _ Nothing = Nothing + + + +map0 :: (a -> b) -> RadixTree a -> RadixTree b +map0 f (RadixTree mx t) = RadixTree (fmap f mx) $ map1 f t + +map1 :: (a -> b) -> Radix1Tree a -> Radix1Tree b +map1 f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) (go r) + Tip arr mx dx -> Tip arr (fmap f mx) (go dx) + Nil -> Nil + + + +map0' :: (a -> b) -> RadixTree a -> RadixTree b +map0' f (RadixTree mx t) = RadixTree (fmap' f mx) $ map1 f t + +map1' :: (a -> b) -> Radix1Tree a -> Radix1Tree b +map1' f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) (go r) + Tip arr mx dx -> Tip arr (fmap' f mx) (go dx) + Nil -> Nil + + + +mapWithKey0 :: (Build -> a -> b) -> RadixTree a -> RadixTree b +mapWithKey0 f (RadixTree mx t) = + RadixTree (f (Build Lin) <$> mx) $ + mapWithKey_ (\b arr -> f (Build $ Snoc b arr)) Lin t + +mapWithKey1 :: (Build1 -> a -> b) -> Radix1Tree a -> Radix1Tree b +mapWithKey1 f = mapWithKey_ (\b arr -> f (Build1 $ b :/ arr)) Lin + +{-# INLINE mapWithKey_ #-} +mapWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> b) -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b +mapWithKey_ f = go + where + go b t = + case t of + Bin p l r -> Bin p (go b l) (go b r) + Tip arr mx dx -> Tip arr (f b arr <$> mx) (go (Snoc b arr) dx) + Nil -> Nil + + + +mapWithKey0' :: (Build -> a -> b) -> RadixTree a -> RadixTree b +mapWithKey0' f (RadixTree mx t) = + RadixTree (f (Build Lin) `fmap'` mx) $ + mapWithKey'_ (\b arr -> f (Build $ Snoc b arr)) Lin t + +mapWithKey1' :: (Build1 -> a -> b) -> Radix1Tree a -> Radix1Tree b +mapWithKey1' f = mapWithKey'_ (\b arr -> f (Build1 $ b :/ arr)) Lin + +{-# INLINE mapWithKey'_ #-} +mapWithKey'_ + :: (Tsil ByteArray -> ByteArray -> a -> b) -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b +mapWithKey'_ f = go + where + go b t = + case t of + Bin p l r -> Bin p (go b l) (go b r) + Tip arr mx dx -> Tip arr (f b arr `fmap'` mx) (go (Snoc b arr) dx) + Nil -> Nil + + + +foldl0 :: (b -> a -> b) -> b -> RadixTree a -> b +foldl0 f z (RadixTree mx t) = + let z' = case mx of + Just x -> f z x + Nothing -> z + + in Data.RadixNTree.Word8.Strict.foldl1 f z' t + +foldl1 :: (b -> a -> b) -> b -> Radix1Tree a -> b +foldl1 f = go + where + go z t = + case t of + Bin _ l r -> go (go z l) r + + Tip _ mx dx -> let z' = case mx of + Just x -> f z x + Nothing -> z + + in go z' dx + + Nil -> z + + + +foldl0' :: (b -> a -> b) -> b -> RadixTree a -> b +foldl0' f z (RadixTree mx t) = + let !z' = case mx of + Just x -> f z x + Nothing -> z + + in Data.RadixNTree.Word8.Strict.foldl1' f z' t + +foldl1' :: (b -> a -> b) -> b -> Radix1Tree a -> b +foldl1' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z l + in go z' r + + Tip _ mx dx -> let !z' = case mx of + Just x -> f z x + Nothing -> z + + in go z' dx + + Nil -> z + + + +foldlWithKey0 :: (b -> Build -> a -> b) -> b -> RadixTree a -> b +foldlWithKey0 f z (RadixTree mx t) = + let z' = case mx of + Just x -> f z (Build Lin) x + Nothing -> z + + in foldlWithKey_ (\z'' b arr -> f z'' (Build $ Snoc b arr)) z' t + +foldlWithKey1 :: (b -> Build1 -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey1 f = foldlWithKey_ (\z b arr -> f z (Build1 $ b :/ arr)) + +{-# INLINE foldlWithKey_ #-} +foldlWithKey_ :: (b -> Tsil ByteArray -> ByteArray -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey_ f = go Lin + where + go b z t = + case t of + Bin _ l r -> go b (go b z l) r + + Tip arr mx dx -> + case mx of + Nothing -> go (Snoc b arr) z dx + Just a -> go (Snoc b arr) (f z b arr a) dx + + Nil -> z + + + +foldlWithKey0' :: (b -> Build -> a -> b) -> b -> RadixTree a -> b +foldlWithKey0' f z (RadixTree mx t) = + let !z' = case mx of + Just x -> f z (Build Lin) x + Nothing -> z + + in foldlWithKey'_ (\z'' b arr -> f z'' (Build $ Snoc b arr)) z' t + +foldlWithKey1' :: (b -> Build1 -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey1' f = foldlWithKey'_ (\z b arr -> f z (Build1 $ b :/ arr)) + +{-# INLINE foldlWithKey'_ #-} +foldlWithKey'_ :: (b -> Tsil ByteArray -> ByteArray -> a -> b) -> b -> Radix1Tree a -> b +foldlWithKey'_ f = go Lin + where + go b !z t = + case t of + Bin _ l r -> let !z' = go b z l + in go b z' r + + Tip arr mx dx -> + case mx of + Nothing -> go (Snoc b arr) z dx + Just a -> let !z' = f z b arr a + in go (Snoc b arr) z' dx + + Nil -> z + + + +foldr0 :: (a -> b -> b) -> b -> RadixTree a -> b +foldr0 f z (RadixTree mx t) = + let z' = Data.RadixNTree.Word8.Strict.foldr1 f z t + in case mx of + Just x -> f x z' + Nothing -> z' + +foldr1 :: (a -> b -> b) -> b -> Radix1Tree a -> b +foldr1 f = go + where + go z t = + case t of + Bin _ l r -> go (go z r) l + + Tip _ mx dx -> let z' = go z dx + in case mx of + Just x -> f x z' + Nothing -> z' + + Nil -> z + + + +foldr0' :: (a -> b -> b) -> b -> RadixTree a -> b +foldr0' f z (RadixTree mx t) = + let !z' = Data.RadixNTree.Word8.Strict.foldr1' f z t + in case mx of + Just x -> f x z' + Nothing -> z' + +foldr1' :: (a -> b -> b) -> b -> Radix1Tree a -> b +foldr1' f = go + where + go !z t = + case t of + Bin _ l r -> let !z' = go z r + in go z' l + + Tip _ mx dx -> let !z' = go z dx + in case mx of + Just x -> f x z' + Nothing -> z' + + Nil -> z + + + +foldrWithKey0 :: (Build -> a -> b -> b) -> b -> RadixTree a -> b +foldrWithKey0 f z (RadixTree mx t) = + let z' = foldrWithKey_ (\b arr -> f (Build $ Snoc b arr)) z t + in case mx of + Just x -> f (Build Lin) x z' + Nothing -> z' + +foldrWithKey1 :: (Build1 -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey1 f = foldrWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE foldrWithKey_ #-} +foldrWithKey_ :: (Tsil ByteArray -> ByteArray -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey_ f = go Lin + where + go b z t = + case t of + Bin _ l r -> go b (go b z r) l + + Tip arr mx dx -> let z' = go (Snoc b arr) z dx + in case mx of + Just x -> f b arr x z' + Nothing -> z' + + Nil -> z + + + +foldrWithKey0' :: (Build -> a -> b -> b) -> b -> RadixTree a -> b +foldrWithKey0' f z (RadixTree mx t) = + let !z' = foldrWithKey'_ (\b arr -> f (Build $ Snoc b arr)) z t + in case mx of + Just x -> f (Build Lin) x z' + Nothing -> z' + +foldrWithKey1' :: (Build1 -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey1' f = foldrWithKey'_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE foldrWithKey'_ #-} +foldrWithKey'_ :: (Tsil ByteArray -> ByteArray -> a -> b -> b) -> b -> Radix1Tree a -> b +foldrWithKey'_ f = go Lin + where + go b !z t = + case t of + Bin _ l r -> let !z' = go b z r + in go b z' l + + Tip arr mx dx -> let !z' = go (Snoc b arr) z dx + in case mx of + Just x -> f b arr x z' + Nothing -> z' + + Nil -> z + + + +foldMap0 :: Monoid m => (a -> m) -> RadixTree a -> m +foldMap0 f (RadixTree mx t) = + let m = foldMap1 f t + in case mx of + Just x -> f x <> m + Nothing -> m + +foldMap1 :: Monoid m => (a -> m) -> Radix1Tree a -> m +foldMap1 f = go + where + go t = + case t of + Bin _ l r -> go l <> go r + + Tip _ mx dx -> let m = go dx + in case mx of + Nothing -> m + Just a -> f a <> m + + Nil -> mempty + + + +foldMapWithKey0 :: Monoid m => (Build -> a -> m) -> RadixTree a -> m +foldMapWithKey0 f (RadixTree mx t) = + let m = foldMapWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + in case mx of + Just x -> f (Build Lin) x <> m + Nothing -> m + +foldMapWithKey1 :: Monoid m => (Build1 -> a -> m) -> Radix1Tree a -> m +foldMapWithKey1 f = foldMapWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE foldMapWithKey_ #-} +foldMapWithKey_ + :: Monoid m => (Tsil ByteArray -> ByteArray -> a -> m) -> Radix1Tree a -> m +foldMapWithKey_ f = go Lin + where + go b t = + case t of + Bin _ l r -> go b l <> go b r + + Tip arr mx dx -> + let m = go (Snoc b arr) dx + in case mx of + Nothing -> m + Just a -> f b arr a <> m + + Nil -> mempty + + + +traverse0 :: Applicative f => (a -> f b) -> RadixTree a -> f (RadixTree b) +traverse0 f (RadixTree mx t) = + let dy = traverse1 f t + in case mx of + Just x -> liftA2 RadixTree (Just <$> f x) dy + Nothing -> RadixTree Nothing <$> dy + +traverse1 :: Applicative f => (a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverse1 f = go + where + go t = + case t of + Bin p l r -> liftA2 (Bin p) (go l) (go r) + + Tip arr mx dx -> + case mx of + Nothing -> Tip arr Nothing <$> go dx + Just x -> liftA2 (Tip arr . Just) (f x) (go dx) + + Nil -> pure Nil + + + +traverseWithKey0 :: Applicative f => (Build -> a -> f b) -> RadixTree a -> f (RadixTree b) +traverseWithKey0 f (RadixTree mx t) = + let dy = traverseWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + in case mx of + Just x -> liftA2 RadixTree (Just <$> f (Build Lin) x) dy + Nothing -> RadixTree Nothing <$> dy + +traverseWithKey1 + :: Applicative f => (Build1 -> a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverseWithKey1 f = traverseWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE traverseWithKey_ #-} +traverseWithKey_ + :: Applicative f + => (Tsil ByteArray -> ByteArray -> a -> f b) -> Radix1Tree a -> f (Radix1Tree b) +traverseWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> liftA2 (Bin p) (go b l) (go b r) + + Tip arr mx dx -> + let dy = go (Snoc b arr) dx + in case mx of + Nothing -> Tip arr Nothing <$> dy + Just a -> liftA2 (Tip arr . Just) (f b arr a) dy + + Nil -> pure Nil + + + +{-# INLINE lookup0 #-} +lookup0 :: Feed -> RadixTree a -> Maybe a +lookup0 (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> lookup_ step w z t + Done -> mx + +{-# INLINE lookup1 #-} +lookup1 :: Feed1 -> Radix1Tree a -> Maybe a +lookup1 (Feed1 w feed) = feed $ \step -> lookup_ step w + +{-# INLINE lookup_ #-} +lookup_ :: (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Maybe a +lookup_ step = go + where + go w s t = + case t of + Bin p l r -> + go w s $ if w < p + then l + else r + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + let n' = n + 1 + in if n' >= sizeofByteArray arr + then case step z of + More u z' -> go u z' dx + Done -> mx + + else case step z of + More u z' -> goarr u z' n' + Done -> Nothing + + | otherwise = Nothing + + Nil -> Nothing + + + +{-# INLINE find0 #-} +find0 :: a -> Feed -> RadixTree a -> a +find0 d (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> find_ d step w z t + Done -> case mx of + Just x -> x + Nothing -> d + +{-# INLINE find1 #-} +find1 :: a -> Feed1 -> Radix1Tree a -> a +find1 d (Feed1 w feed) = feed $ \step -> find_ d step w + +{-# INLINE find_ #-} +find_ :: a -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> a +find_ d step = go + where + go w s t = + case t of + Bin p l r -> + go w s $ if w < p + then l + else r + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + let n' = n + 1 + in if n' >= sizeofByteArray arr + then case step z of + More u z' -> go u z' dx + Done -> case mx of + Just x -> x + Nothing -> d + + else case step z of + More u z' -> goarr u z' n' + Done -> d + + | otherwise = d + + Nil -> d + + + +{-# INLINE member0 #-} +member0 :: Feed -> RadixTree a -> Bool +member0 (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> member_ step w z t + Done -> case mx of + Just _ -> True + Nothing -> False + +{-# INLINE member1 #-} +member1 :: Feed1 -> Radix1Tree a -> Bool +member1 (Feed1 w feed) = feed $ \step -> member_ step w + +{-# INLINE member_ #-} +member_ :: (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Bool +member_ step = go + where + go w s t = + case t of + Bin p l r -> + go w s $ if w < p + then l + else r + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + let n' = n + 1 + in if n' >= sizeofByteArray arr + then case step z of + More u z' -> go u z' dx + Done -> case mx of + Just _ -> True + Nothing -> False + + else case step z of + More u z' -> goarr u z' n' + Done -> False + + | otherwise = False + + Nil -> False + + + +{-# INLINE subtree0 #-} +subtree0 :: Feed -> RadixTree a -> RadixTree a +subtree0 (Feed feed) = \t0@(RadixTree _ t) -> + feed $ \step s -> + case step s of + More w z -> subtree_ step w z t + Done -> t0 + +{-# INLINE subtree1 #-} +subtree1 :: Feed1 -> Radix1Tree a -> RadixTree a +subtree1 (Feed1 w feed) = feed $ \step -> subtree_ step w + +{-# INLINE subtree_ #-} +subtree_ :: (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> RadixTree a +subtree_ step = go + where + go w s t = + case t of + Bin p l r -> + go w s $ if w < p + then l + else r + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> go u z' dx + Done -> RadixTree mx dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> let rest = dropTrim (n + 1) arr mx dx + in rest `seq` RadixTree Nothing rest + + | otherwise = RadixTree Nothing Nil + + Nil -> RadixTree Nothing Nil + + + +{-# INLINE prefix0 #-} +prefix0 :: Feed -> RadixTree a -> RadixTree a +prefix0 (Feed feed) = \t -> + feed $ \step s -> + case step s of + More w z -> RadixTree Nothing $ prefix_ step w z t + Done -> t + +{-# INLINE prefix1 #-} +prefix1 :: Feed1 -> RadixTree a -> Radix1Tree a +prefix1 (Feed1 w feed) = + feed $ \step -> prefix_ step w + +{-# INLINE prefix_ #-} +prefix_ :: (x -> Step Word8 x) -> Word8 -> x -> RadixTree a -> Radix1Tree a +prefix_ step = \w z (RadixTree mx t) -> + case mx of + Nothing -> + case t of + Bin _ _ _ -> Tip (fromStep step w z) Nothing t + Tip arr my dy -> Tip (fromStepAppend step w z arr) my dy + Nil -> Nil + + Just _ -> Tip (fromStep step w z) mx t + + + +-- | Current position in the tree. +data Point = -- | Above a node. + Seam + + -- | In the middle of a 'Tip'. + | Plane + {-# UNPACK #-} !Int -- ^ Always greater than @0@ and smaller than + -- the length of the 'ByteArray'. + {-# UNPACK #-} !ByteArray + +-- | A particular point in the tree. +data Cursor a = -- | This is effectively a 'Tip' where the 'ByteArray' is optional. + Cursor + {-# UNPACK #-} !Point + {-# UNPACK #-} !(Maybe a) + !(Radix1Tree a) + +instance Show a => Show (Cursor a) where + showsPrec d c = + showParen (d > 10) $ + showString "Cursor " . showsPrec 11 (stop c) + +cursor0 :: RadixTree a -> Cursor a +cursor0 (RadixTree mx t) = Cursor Seam mx t + +cursor1 :: Radix1Tree a -> Cursor a +cursor1 = Cursor Seam Nothing + +{-# INLINE move0 #-} +move0 :: Feed -> Cursor a -> Cursor a +move0 (Feed feed) = \c -> + feed $ \step s -> + case step s of + More w z -> move_ step w z c + Done -> c + +{-# INLINE move1 #-} +move1 :: Feed1 -> Cursor a -> Cursor a +move1 (Feed1 w feed) = feed $ \step -> move_ step w + +{-# INLINE move_ #-} +move_ :: (x -> Step Word8 x) -> Word8 -> x -> Cursor a -> Cursor a +move_ step = \w s (Cursor point mx dx) -> + case point of + Seam -> go w s dx + Plane i arr -> goarr arr mx dx w s i + where + go w s t = + case t of + Bin p l r -> go w s $ if w < p + then l + else r + + Tip brr my dy -> goarr brr my dy w s 0 + + Nil -> Cursor Seam Nothing Nil + + goarr arr mx dx = goarr_ + where + goarr_ w s n + | w == indexByteArray arr n = + let !n' = n + 1 + in case step s of + More v z + | n' >= sizeofByteArray arr -> go v z dx + | otherwise -> goarr_ v z n' + + Done -> + let !point' + | n' >= sizeofByteArray arr = Seam + | otherwise = Plane n' arr + + in Cursor point' mx dx + + | otherwise = Cursor Seam Nothing Nil + +-- | \(\mathcal{O}(1)\). +-- Retrieve the value at which the cursor points. +stop :: Cursor a -> Maybe a +stop (Cursor point mx _) = + case point of + Seam -> mx + _ -> Nothing + +-- | \(\mathcal{O}(1)\). +-- Determine whether the cursor points to a point within the tree. +locate :: Cursor a -> Location +locate (Cursor _ Nothing Nil) = Outside +locate _ = Inside + + + +{-# INLINE lookupL0 #-} +lookupL0 :: Openness -> Feed -> RadixTree a -> Maybe (Lookup a) +lookupL0 openness (Feed feed) (RadixTree mx t) = + feed $ \step s -> + case step s of + More w z -> + let l = lookupL_ (\b arr -> Lookup (Build $ Snoc b arr)) openness step w z t + in case l of + Just _ -> l + Nothing -> + case mx of + Just x -> Just $ Lookup (Build Lin) x + Nothing -> Nothing + + _ -> + case openness of + Open -> Nothing + Closed -> case mx of + Just x -> Just $ Lookup (Build Lin) x + Nothing -> Nothing + +{-# INLINE lookupL1 #-} +lookupL1 :: Openness -> Feed1 -> Radix1Tree a -> Maybe (Lookup1 a) +lookupL1 openness (Feed1 w feed) = + feed $ \step -> lookupL_ (\b arr -> Lookup1 (Build1 (b :/ arr))) openness step w + +{-# INLINE lookupL_ #-} +lookupL_ + :: (Tsil ByteArray -> ByteArray -> a -> b) + -> Openness -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Maybe b +lookupL_ f openness step = go Lin Nothing + where + getMax b t = + let !(# b', arr, a #) = unsafeLookupMaxWithKey_ b t + in Just $! f b' arr a + + go b getL !w !s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go b getL w s l + else getL + + else if w <= upper p + then go b (getMax b l) w s r + else getMax b r + + Tip arr mx dx -> goarr w s 0 + where + getThis = f b arr `fmap'` mx + + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + let getL' = getThis <|> getL + in case step z of + More u z' -> go (Snoc b arr) getL' u z' dx + Done -> + case openness of + Open -> getL + Closed -> getL' + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> getL + + LT -> case dx of + Nil -> getThis + _ -> getMax (Snoc b arr) dx + + GT -> getL + + Nil -> getL + + + +{-# INLINE lookupR0 #-} +lookupR0 :: Openness -> Feed -> RadixTree a -> Maybe (Lookup a) +lookupR0 openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + lookupR_ (\b arr -> Lookup (Build $ Snoc b arr)) openness step w z t + + _ -> + case openness of + Closed | Just x <- mx -> Just $ Lookup (Build Lin) x + + _ -> case t of + Nil -> Nothing + _ -> let !(# b, arr, x #) = unsafeLookupMinWithKey_ Lin t + in Just $! Lookup (Build $ Snoc b arr) x + +{-# INLINE lookupR1 #-} +lookupR1 :: Openness -> Feed1 -> Radix1Tree a -> Maybe (Lookup1 a) +lookupR1 openness (Feed1 w feed) = + feed $ \step -> lookupR_ (\b arr -> Lookup1 (Build1 (b :/ arr))) openness step w + +{-# INLINE lookupR_ #-} +lookupR_ + :: (Tsil ByteArray -> ByteArray -> a -> b) + -> Openness -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Maybe b +lookupR_ f openness step = go Lin Nothing + where + getMin b t = + let !(# b', arr, a #) = unsafeLookupMinWithKey_ b t + in Just $! f b' arr a + + go b getR w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go b (getMin b r) w s l + else getMin b l + + else if w <= upper p + then go b getR w s r + else getR + + Tip arr mx dx -> goarr w s 0 + where + getThis = f b arr `fmap'` mx + + getBelow = + case dx of + Nil -> Nothing + _ -> getMin (Snoc b arr) dx + + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> go (Snoc b arr) getR u z' dx + Done -> + ( case openness of + Open -> getBelow + Closed -> getThis <|> getBelow + ) + <|> getR + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> (getThis <|> getBelow) <|> getR + + GT -> getThis <|> getBelow + + LT -> getR + + Nil -> getR + + + +{-# INLINE adjustL0 #-} +adjustL0 :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustL0 f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree (f <$> mx) $ adjustL_ f openness step w z t + Done -> + case openness of + Open -> t0 + Closed -> case mx of + Just x -> RadixTree (Just $ f x) t + Nothing -> t0 + +{-# INLINE adjustL1 #-} +adjustL1 :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustL1 f openness (Feed1 w feed) = + feed $ \step -> adjustL_ f openness step w + +{-# INLINE adjustL_ #-} +adjustL_ + :: (a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustL_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go w s l) r + else t + + else if w <= upper p + then Bin p (map1 f l) (go w s r) + else map1 f t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr (f <$> mx) $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f <$> mx + + in Tip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> map1 f t + + GT -> t + + Nil -> Nil + + + +{-# INLINE adjustL0' #-} +adjustL0' :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustL0' f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree (f `fmap'` mx) $ adjustL'_ f openness step w z t + Done -> + case openness of + Open -> t0 + Closed -> case mx of + Just x -> RadixTree (Just $! f x) t + Nothing -> t0 + +{-# INLINE adjustL1' #-} +adjustL1' :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustL1' f openness (Feed1 w feed) = + feed $ \step -> adjustL'_ f openness step w + +{-# INLINE adjustL'_ #-} +adjustL'_ + :: (a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustL'_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go w s l) r + else t + + else if w <= upper p + then Bin p (map1' f l) (go w s r) + else map1' f t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr (f `fmap'` mx) $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f `fmap'` mx + + in Tip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> map1' f t + + GT -> t + + Nil -> Nil + + + +{-# INLINE adjustLWithKey0 #-} +adjustLWithKey0 :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustLWithKey0 f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree (f (Build Lin) <$> mx) $ + adjustLWithKey_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + Done -> + case openness of + Open -> t0 + Closed -> RadixTree (f (Build Lin) <$> mx) t + +{-# INLINE adjustLWithKey1 #-} +adjustLWithKey1 :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustLWithKey1 f openness (Feed1 w feed) = + feed $ \step -> adjustLWithKey_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE adjustLWithKey_ #-} +adjustLWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustLWithKey_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go b w s l) r + else t + + else if w <= upper p + then Bin p (mapWithKey_ f b l) (go b w s r) + else mapWithKey_ f b t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr (f b arr <$> mx) $ + go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr <$> mx + + in Tip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> mapWithKey_ f b t + + GT -> t + + Nil -> Nil + + + +{-# INLINE adjustLWithKey0' #-} +adjustLWithKey0' :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustLWithKey0' f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + RadixTree (f (Build Lin) `fmap'` mx) $ + adjustLWithKey'_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + + Done -> + case openness of + Open -> t0 + Closed -> case mx of + Just x -> RadixTree (Just $! f (Build Lin) x) t + Nothing -> t0 + +{-# INLINE adjustLWithKey1' #-} +adjustLWithKey1' + :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustLWithKey1' f openness (Feed1 w feed) = + feed $ \step -> adjustLWithKey'_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE adjustLWithKey'_ #-} +adjustLWithKey'_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustLWithKey'_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go b w s l) r + else t + + else if w <= upper p + then Bin p (mapWithKey'_ f b l) (go b w s r) + else mapWithKey'_ f b t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr (f b arr `fmap'` mx) $ + go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr `fmap'` mx + + in Tip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> mapWithKey'_ f b t + + GT -> t + + Nil -> Nil + + + +{-# INLINE adjustR0 #-} +adjustR0 :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustR0 f openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ adjustR_ f openness step w z t + Done -> + let my = case openness of + Open -> mx + Closed -> f <$> mx + + in RadixTree my (map1 f t) + +{-# INLINE adjustR1 #-} +adjustR1 :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustR1 f openness (Feed1 w feed) = + feed $ \step -> adjustR_ f openness step w + +{-# INLINE adjustR_ #-} +adjustR_ + :: (a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustR_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go w s l) (map1 f r) + else map1 f t + + else if w <= upper p + then Bin p l (go w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr mx $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f <$> mx + + in Tip arr my $ map1 f dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> map1 f t + + GT -> map1 f t + + LT -> t + + Nil -> Nil + + + +{-# INLINE adjustR0' #-} +adjustR0' :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustR0' f openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ adjustR'_ f openness step w z t + Done -> + let my = case openness of + Open -> mx + Closed -> f `fmap'` mx + + in RadixTree my (map1' f t) + +{-# INLINE adjustR1' #-} +adjustR1' :: (a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustR1' f openness (Feed1 w feed) = + feed $ \step -> adjustR'_ f openness step w + +{-# INLINE adjustR'_ #-} +adjustR'_ + :: (a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustR'_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go w s l) (map1' f r) + else map1' f t + + else if w <= upper p + then Bin p l (go w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr mx $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f `fmap'` mx + + in Tip arr my $ map1' f dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> map1 f t + + GT -> map1' f t + + LT -> t + + Nil -> Nil + + + +{-# INLINE adjustRWithKey0 #-} +adjustRWithKey0 :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustRWithKey0 f openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + RadixTree mx $ + adjustRWithKey_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + + Done -> + let my = case openness of + Open -> mx + Closed -> f (Build Lin) <$> mx + + in RadixTree my $ mapWithKey_ (\b arr -> f (Build $ Snoc b arr)) Lin t + +{-# INLINE adjustRWithKey1 #-} +adjustRWithKey1 :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustRWithKey1 f openness (Feed1 w feed) = + feed $ \step -> adjustRWithKey_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE adjustRWithKey_ #-} +adjustRWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustRWithKey_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go b w s l) (mapWithKey_ f b r) + else mapWithKey_ f b t + + else if w <= upper p + then Bin p l (go b w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr mx $ go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr <$> mx + + in Tip arr my $ mapWithKey_ f (Snoc b arr) dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> mapWithKey_ f b t + + GT -> mapWithKey_ f b t + + LT -> t + + Nil -> Nil + + + +{-# INLINE adjustRWithKey0' #-} +adjustRWithKey0' :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustRWithKey0' f openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + RadixTree mx $ + adjustRWithKey'_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + + Done -> + let my = case openness of + Open -> mx + Closed -> f (Build Lin) `fmap'` mx + + in RadixTree my $ mapWithKey'_ (\b arr -> f (Build $ Snoc b arr)) Lin t + +{-# INLINE adjustRWithKey1' #-} +adjustRWithKey1' + :: (Build1 -> a -> a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjustRWithKey1' f openness (Feed1 w feed) = + feed $ \step -> adjustRWithKey'_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE adjustRWithKey'_ #-} +adjustRWithKey'_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjustRWithKey'_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then Bin p (go b w s l) (mapWithKey'_ f b r) + else mapWithKey'_ f b t + + else if w <= upper p + then Bin p l (go b w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> Tip arr mx $ go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr `fmap'` mx + + in Tip arr my $ mapWithKey'_ f (Snoc b arr) dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> mapWithKey'_ f b t + + GT -> mapWithKey'_ f b t + + LT -> t + + Nil -> Nil + + + +{-# INLINE updateL0 #-} +updateL0 :: (a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateL0 f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree (f =<< mx) $ updateL_ f openness step w z t + Done -> + case openness of + Open -> t0 + Closed -> RadixTree (f =<< mx) t + +{-# INLINE updateL1 #-} +updateL1 :: (a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateL1 f openness (Feed1 w feed) = + feed $ \step -> updateL_ f openness step w + +{-# INLINE updateL_ #-} +updateL_ + :: (a -> Maybe a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +updateL_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go w s l) r + else t + + else if w <= upper p + then rebin p (mapMaybe1 f l) (go w s r) + else mapMaybe1 f t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr (f =<< mx) $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f =<< mx + + in retip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> mapMaybe1 f t + + GT -> t + + Nil -> Nil + + + +{-# INLINE updateLWithKey0 #-} +updateLWithKey0 + :: (Build -> a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateLWithKey0 f openness (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + RadixTree (f (Build Lin) =<< mx) $ + updateLWithKey_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + + Done -> + case openness of + Open -> t0 + Closed -> RadixTree (f (Build Lin) =<< mx) t + +{-# INLINE updateLWithKey1 #-} +updateLWithKey1 + :: (Build1 -> a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateLWithKey1 f openness (Feed1 w feed) = + feed $ \step -> updateLWithKey_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE updateLWithKey_ #-} +updateLWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +updateLWithKey_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go b w s l) r + else t + + else if w <= upper p + then rebin p (mapMaybeWithKey_ f b l) (go b w s r) + else mapMaybeWithKey_ f b t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr (f b arr =<< mx) $ + go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr =<< mx + + in retip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + LT -> mapMaybeWithKey_ f b t + + GT -> t + + Nil -> Nil + + + +{-# INLINE updateR0 #-} +updateR0 :: (a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateR0 f openness (Feed feed) (RadixTree mx t) = + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ updateR_ f openness step w z t + Done -> + let my = case openness of + Open -> mx + Closed -> f =<< mx + + in RadixTree my (mapMaybe1 f t) + +{-# INLINE updateR1 #-} +updateR1 :: (a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateR1 f openness (Feed1 w feed) = + feed $ \step -> updateR_ f openness step w + +{-# INLINE updateR_ #-} +updateR_ + :: (a -> Maybe a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +updateR_ f openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebin p (go w s l) (mapMaybe1 f r) + else mapMaybe1 f t + + else if w <= upper p + then rebinR p l (go w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr mx $ go u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f =<< mx + + in retip arr my $ mapMaybe1 f dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> mapMaybe1 f t + + GT -> mapMaybe1 f t + + LT -> t + + Nil -> Nil + + + +{-# INLINE updateRWithKey0 #-} +updateRWithKey0 + :: (Build -> a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateRWithKey0 f openness (Feed feed) (RadixTree mx t) = + feed $ \step s -> + case step s of + More w z -> + RadixTree mx $ + updateRWithKey_ (\b arr -> f (Build $ Snoc b arr)) openness step w z t + + Done -> + let my = case openness of + Open -> mx + Closed -> f (Build Lin) =<< mx + + in RadixTree my (mapMaybeWithKey_ (\b arr -> f (Build $ Snoc b arr)) Lin t) + +{-# INLINE updateRWithKey1 #-} +updateRWithKey1 + :: (Build1 -> a -> Maybe a) -> Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +updateRWithKey1 f openness (Feed1 w feed) = + feed $ \step -> updateRWithKey_ (\b arr -> f (Build1 $ b :/ arr)) openness step w + +{-# INLINE updateRWithKey_ #-} +updateRWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe a) -> Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +updateRWithKey_ f openness step = go Lin + where + go b w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebin p (go b w s l) (mapMaybeWithKey_ f b r) + else mapMaybeWithKey_ f b t + + else if w <= upper p + then rebinR p l (go b w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr mx $ go (Snoc b arr) u z' dx + Done -> + let my = case openness of + Open -> mx + Closed -> f b arr =<< mx + + in retip arr my $ mapMaybeWithKey_ f (Snoc b arr) dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> mapMaybeWithKey_ f b t + + GT -> mapMaybeWithKey_ f b t + + LT -> t + + Nil -> Nil + + + +{-# INLINE takeL0 #-} +takeL0 :: Openness -> Feed -> RadixTree a -> RadixTree a +takeL0 openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ takeL_ openness step w z t + Done -> + let my = case openness of + Open -> Nothing + Closed -> mx + + in RadixTree my Nil + +{-# INLINE takeL1 #-} +takeL1 :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +takeL1 openness (Feed1 w0 feed) = feed $ \step -> takeL_ openness step w0 + +{-# INLINE takeL_ #-} +takeL_ :: Openness -> (x -> Step Prefix x) -> Prefix -> x -> Radix1Tree a -> Radix1Tree a +takeL_ openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go w s l + else Nil + + else if w <= upper p + then rebinR p l (go w s r) + else t + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr mx $ go u z' dx + Done -> + case openness of + Open -> Nil + Closed -> retip arr mx Nil + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> Nil + + LT -> t + + GT -> Nil + + Nil -> Nil + + + +{-# INLINE takeR0 #-} +takeR0 :: Openness -> Feed -> RadixTree a -> RadixTree a +takeR0 openness (Feed feed) (RadixTree mx t) = + feed $ \step s -> + case step s of + More w z -> RadixTree Nothing $ takeR_ openness step w z t + Done -> + let my = case openness of + Open -> Nothing + Closed -> mx + + in RadixTree my t + +{-# INLINE takeR1 #-} +takeR1 :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +takeR1 openness (Feed1 w0 feed) = feed $ \step -> takeR_ openness step w0 + +{-# INLINE takeR_ #-} +takeR_ :: Openness -> (x -> Step Prefix x) -> Prefix -> x -> Radix1Tree a -> Radix1Tree a +takeR_ openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go w s l) r + else t + + else if w <= upper p + then go w s r + else Nil + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> retip arr Nothing $ go u z' dx + Done -> + let my = case openness of + Open -> Nothing + Closed -> mx + + in retip arr my dx + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> t + + GT -> t + + LT -> Nil + + Nil -> Nil + + + +type UBin a = (# Prefix, Radix1Tree a, Radix1Tree a #) + +type UTip a = (# Key, Int, ByteArray, Maybe a, Radix1Tree a #) + + + +union0 :: RadixTree a -> RadixTree a -> RadixTree a +union0 (RadixTree mA tA) (RadixTree mB tB) = RadixTree (mA <|> mB) (union1 tA tB) + +union1 :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +union1 = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> tB + + tipAny uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip uA tA uB tB lenA + else tipTip uB tB uA tA lenB + + Nil | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + tipTip (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then Tip arrA' (mA <|> mB) (anyAny dA dB) + else Tip arrA' mA $ + tipAny (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | o == 1 = + let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + !tB' | nB == 0 = tB + | otherwise = Tip (dropByteArray nB arrB) mB dB + + in join wA tA' wB tB' + + | otherwise = + let !o' = o - 1 + + !(# !arrC, !arrA' #) = splitByteArray nA o' arrA + + !arrB' = dropByteArray (nB + o') arrB + + in Tip arrC Nothing $ join wA (Tip arrA' mA dA) + wB (Tip arrB' mB dB) + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + in tipBin (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> tA + + tipBin uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + in join wA tA' pB tB + + | wA < pB = Bin pB (tipAny uA tA lB) rB + | otherwise = Bin pB lB (tipAny uA tA rB) + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> Bin pA lA (binAny uB tB rA) + | pA >= lower pB -> Bin pB (binAny uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny uA tA rB) + | pB >= lower pA -> Bin pA (binAny uB tB lA) rA + | otherwise -> no + + + +unionL0 :: RadixTree a -> RadixTree a -> RadixTree a +unionL0 (RadixTree mA tA) (RadixTree mB tB) = RadixTree (mA <|> mB) (unionL1 tA tB) + +unionL1 :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionL1 = + union_ $ \s a b -> + let !(# c #) = case s of + L -> (# a #) + R -> (# b #) + in Just c + + +unionWith0' :: (a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a +unionWith0' f (RadixTree mA tA) (RadixTree mB tB) = + let mC = case mA of + Just a -> case mB of + Just b -> Just $! f a b + Nothing -> mA + + Nothing -> mB + + in RadixTree mC (unionWith1' f tA tB) + +unionWith1' :: (a -> a -> a) -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionWith1' f = + union_ $ \s a b -> + Just $! case s of + L -> f a b + R -> f b a + + + +{-# INLINE union_ #-} +union_ + :: (forall x y. S x y a a -> x -> y -> Maybe a) + -> Radix1Tree a + -> Radix1Tree a + -> Radix1Tree a +union_ f = anyAny L + where + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> tB + + tipAny s uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' uB tB uA tA lenB + + Nil | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + tipTip s (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC = case mA of + Just a -> case mB of + Just b -> f s a b + Nothing -> mA + + Nothing -> mB + + in Tip arrA' mC (anyAny s dA dB) + + else Tip arrA' mA $ + let !(# s' #) = other s + in tipAny s' (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | o == 1 = + let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + !tB' | nB == 0 = tB + | otherwise = Tip (dropByteArray nB arrB) mB dB + + in join wA tA' wB tB' + + | otherwise = + let !o' = o - 1 + + !(# !arrC, !arrA' #) = splitByteArray nA o' arrA + + !arrB' = dropByteArray (nB + o') arrB + + in Tip arrC Nothing $ join wA (Tip arrA' mA dA) + wB (Tip arrB' mB dB) + + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> tA + + tipBin s uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + in join wA tA' pB tB + + | wA < pB = Bin pB (tipAny s uA tA lB) rB + | otherwise = Bin pB lB (tipAny s uA tA rB) + + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in Bin pA lA (binAny s' uB tB rA) + | pA >= lower pB -> Bin pB (binAny s uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny s uA tA rB) + | pB >= lower pA -> let !(# s' #) = other s + in Bin pA (binAny s' uB tB lA) rA + | otherwise -> no + + + + +unionWithKey0' :: (Build -> a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a +unionWithKey0' f (RadixTree mA tA) (RadixTree mB tB) = + let mC = case mA of + Just a -> case mB of + Just b -> Just $! f (Build Lin) a b + Nothing -> mA + + Nothing -> mB + + in RadixTree mC $ unionWithKey_ + ( \s b arr vA vB -> + Just $! let b0 = Build $ Snoc b arr + in case s of + L -> f b0 vA vB + R -> f b0 vB vA + ) + tA tB + +unionWithKey1' :: (Build1 -> a -> a -> a) -> Radix1Tree a -> Radix1Tree a -> Radix1Tree a +unionWithKey1' f = + unionWithKey_ $ \s b arr vA vB -> + Just $! let b1 = Build1 $ b :/ arr + in case s of + L -> f b1 vA vB + R -> f b1 vB vA + +{-# INLINE unionWithKey_ #-} +unionWithKey_ + :: (forall x y. S x y a a -> Tsil ByteArray -> ByteArray -> x -> y -> Maybe a) + -> Radix1Tree a + -> Radix1Tree a + -> Radix1Tree a +unionWithKey_ f = anyAny L Lin + where + anyAny s b tA tB = + case tA of + Bin pA lA rA -> binAny s b (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s b (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> tB + + tipAny s b uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s b uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' b uB tB uA tA lenB + + Nil | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + tipTip s b (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC = + case mA of + Just xA -> + case mB of + Just xB -> f s b arrA' xA xB + Nothing -> mA + + Nothing -> mB + + in Tip arrA' mC (anyAny s (Snoc b arrA') dA dB) + + else Tip arrA' mA $ + let !(# s' #) = other s + in tipAny s' (Snoc b arrA') + (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | o == 1 = + let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + !tB' | nB == 0 = tB + | otherwise = Tip (dropByteArray nB arrB) mB dB + + in join wA tA' wB tB' + + | otherwise = + let !o' = o - 1 + + !(# !arrC, !arrA' #) = splitByteArray nA o' arrA + + !arrB' = dropByteArray (nB + o') arrB + + in Tip arrC Nothing $ join wA (Tip arrA' mA dA) + wB (Tip arrB' mB dB) + + binAny s b uA tA tB = + case tB of + Bin pB lB rB -> binBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' b (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> tA + + tipBin s b uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = let !tA' | nA == 0 = tA + | otherwise = Tip (dropByteArray nA arrA) mA dA + + in join wA tA' pB tB + + | wA < pB = Bin pB (tipAny s b uA tA lB) rB + | otherwise = Bin pB lB (tipAny s b uA tA rB) + + binBin s b uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = join pA tA pB tB + + in case Prelude.compare pA pB of + EQ -> Bin pA (anyAny s b lA lB) (anyAny s b rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in Bin pA lA (binAny s' b uB tB rA) + | pA >= lower pB -> Bin pB (binAny s b uA tA lB) rB + | otherwise -> no + + GT | pA <= upper pB -> Bin pB lB (binAny s b uA tA rB) + | pB >= lower pA -> let !(# s' #) = other s + in Bin pA (binAny s' b uB tB lA) rA + | otherwise -> no + + + +difference0 :: RadixTree a -> RadixTree b -> RadixTree a +difference0 (RadixTree mA tA) (RadixTree mB tB) = + let mC = case mB of + Just _ -> Nothing + Nothing -> mA + + in RadixTree mC $ difference1 tA tB + +difference1 :: Radix1Tree a -> Radix1Tree b -> Radix1Tree a +difference1 = + difference_ $ \_ _ _ -> + Nothing + + +differenceWith0 + :: (a -> b -> Maybe a) -> RadixTree a -> RadixTree b -> RadixTree a +differenceWith0 f (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just xA <- mA, Just xB <- mB = f xA xB + | otherwise = mA + + in RadixTree mC $ differenceWith1 f tA tB + +differenceWith1 + :: (a -> b -> Maybe a) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree a +differenceWith1 f = + difference_ $ \s xA xB -> + case s of + L -> f xA xB + R -> f xB xA + +{-# INLINE difference_ #-} +difference_ + :: (forall x y. S x y a b -> x -> y -> Maybe a) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree a +difference_ (f :: forall n o. S n o x y -> n -> o -> Maybe x) = anyAny L + where + anyAny :: forall a b. S a b x y -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> case s of + L -> Nil + R -> tB + + tipAny + :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + tipAny s uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' uB tB uA tA lenB + + Nil -> case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R -> Nil + + tipTip + :: forall a b. S a b x y + -> UTip a -> Radix1Tree a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree x + tipTip s (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just xA <- mA, Just xB <- mB = f s xA xB + | otherwise = + case s of + L -> mA + R -> mB + + in retip arrA' mC (anyAny s dA dB) + + else let mA' = case s of + L -> mA + R -> Nothing + + in retip arrA' mA' $ + let !(# s' #) = other s + in tipAny s' (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = + case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R | nB == 0 -> tB + | otherwise -> Tip (dropByteArray nB arrB) mB dB + + binAny + :: forall a b. S a b x y -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> case s of + L -> tA + R -> tB + + tipBin + :: forall a b. S a b x y + -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree x + tipBin s uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R -> tB + + | wA < pB = case s of + L -> tipAny s uA tA lB + R -> rebinL pB (tipAny s uA tA lB) rB + + | otherwise = case s of + L -> tipAny s uA tA rB + R -> rebinR pB lB (tipAny s uA tA rB) + + binBin + :: forall a b. S a b x y + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree x + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let no = case s of + L -> tA + R -> tB + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> case s of + L -> rebinR pA lA (binAny R uB tB rA) + R -> binAny L uB tB rA + + | pA >= lower pB -> case s of + L -> binAny s uA tA lB + R -> rebinL pB (binAny s uA tA lB) rB + + | otherwise -> no + + GT | pA <= upper pB -> case s of + L -> binAny s uA tA rB + R -> rebinR pB lB (binAny s uA tA rB) + + | pB >= lower pA -> case s of + L -> rebinL pA (binAny R uB tB lA) rA + R -> binAny L uB tB lA + + | otherwise -> no + + + +differenceWithKey0 + :: (Build -> a -> b -> Maybe a) -> RadixTree a -> RadixTree b -> RadixTree a +differenceWithKey0 f (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just xA <- mA, Just xB <- mB = f (Build Lin) xA xB + | otherwise = mA + + in RadixTree mC $ differenceWithKey_ + ( \s b arr xA xB -> + let b0 = Build $ Snoc b arr + in case s of + L -> f b0 xA xB + R -> f b0 xB xA + ) + tA tB + +differenceWithKey1 + :: (Build1 -> a -> b -> Maybe a) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree a +differenceWithKey1 f = + differenceWithKey_ $ \s b arr xA xB -> + let b1 = Build1 $ b :/ arr + in case s of + L -> f b1 xA xB + R -> f b1 xB xA + +{-# INLINE differenceWithKey_ #-} +differenceWithKey_ + :: (forall x y. S x y a b -> Tsil ByteArray -> ByteArray -> x -> y -> Maybe a) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree a +differenceWithKey_ + (f :: forall n o. S n o x y -> Tsil ByteArray -> ByteArray -> n -> o -> Maybe x) = + anyAny L Lin + where + anyAny + :: forall a b. S a b x y -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + anyAny s b tA tB = + case tA of + Bin pA lA rA -> binAny s b (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s b (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> case s of + L -> Nil + R -> tB + + tipAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + tipAny s b uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s b uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' b uB tB uA tA lenB + + Nil -> case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R -> Nil + + tipTip + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree x + tipTip s b (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just xA <- mA, Just xB <- mB = + f s b arrA' xA xB + + | otherwise = + case s of + L -> mA + R -> mB + + in retip arrA' mC (anyAny s (Snoc b arrA') dA dB) + + else let mA' = case s of + L -> mA + R -> Nothing + + in retip arrA' mA' $ + let !(# s' #) = other s + in tipAny s' (Snoc b arrA') + (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = + case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R | nB == 0 -> tB + | otherwise -> Tip (dropByteArray nB arrB) mB dB + + binAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree x + binAny s b uA tA tB = + case tB of + Bin pB lB rB -> binBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' b (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> case s of + L -> tA + R -> tB + + tipBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree x + tipBin s b uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = case s of + L | nA == 0 -> tA + | otherwise -> Tip (dropByteArray nA arrA) mA dA + + R -> tB + + | wA < pB = case s of + L -> tipAny s b uA tA lB + R -> rebinL pB (tipAny s b uA tA lB) rB + + | otherwise = case s of + L -> tipAny s b uA tA rB + R -> rebinR pB lB (tipAny s b uA tA rB) + + binBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree x + binBin s b uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let no = case s of + L -> tA + R -> tB + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s b lA lB) (anyAny s b rA rB) + + LT | pB <= upper pA -> case s of + L -> rebinR pA lA (binAny R b uB tB rA) + R -> binAny L b uB tB rA + + | pA >= lower pB -> case s of + L -> binAny s b uA tA lB + R -> rebinL pB (binAny s b uA tA lB) rB + + | otherwise -> no + + GT | pA <= upper pB -> case s of + L -> binAny s b uA tA rB + R -> rebinR pB lB (binAny s b uA tA rB) + + | pB >= lower pA -> case s of + L -> rebinL pA (binAny R b uB tB lA) rA + R -> binAny L b uB tB lA + + | otherwise -> no + + + +compare0 :: (a -> b -> Bool) -> RadixTree a -> RadixTree b -> PartialOrdering +compare0 f (RadixTree mA tA) (RadixTree mB tB) = + let o = case mA of + Just xA -> case mB of + Just xB + | f xA xB -> Equal + | otherwise -> Incomparable + + Nothing -> Superset + + Nothing -> case mB of + Just _ -> Subset + Nothing -> Equal + + in order o $ Data.RadixNTree.Word8.Strict.compare1 f tA tB + +compare1 :: (a -> b -> Bool) -> Radix1Tree a -> Radix1Tree b -> PartialOrdering +compare1 (f :: x -> y -> Bool) = anyAny L + where + anyAny :: forall a b. S a b x y -> Radix1Tree a -> Radix1Tree b -> PartialOrdering + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> case tB of + Nil -> Equal + _ -> case s of + L -> Subset + R -> Superset + + tipAny + :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> Radix1Tree b -> PartialOrdering + tipAny s uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s uA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' uB uA tA lenB + + Nil -> case s of + L -> Superset + R -> Subset + + tipTip + :: forall a b. S a b x y -> UTip a -> UTip b -> Radix1Tree b -> Int -> PartialOrdering + tipTip s (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then if nB' == sizeofByteArray arrB + then let o_ = case mA of + Just xA -> case mB of + Just xB -> + let eq = case s of + L -> f xA xB + R -> f xB xA + + in if eq + then Equal + else Incomparable + + Nothing -> case s of + L -> Superset + R -> Subset + Nothing -> case mB of + Just _ -> case s of + L -> Subset + R -> Superset + + Nothing -> Equal + + in order o_ $ anyAny s dA dB + + else let !(# s' #) = other s + in tipAny s' (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = case s of + L -> Superset + R -> Subset + + binAny + :: forall a b. S a b x y -> UBin a -> Radix1Tree a -> Radix1Tree b -> PartialOrdering + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> case s of + L -> Superset + R -> Subset + + tipBin :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> UBin b -> PartialOrdering + tipBin s uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = Incomparable + | otherwise = limit s . tipAny s uA tA $ if wA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> PartialOrdering + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> order (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in limit s' $ binAny s' uB tB rA + | pA >= lower pB -> limit s $ binAny s uA tA lB + | otherwise -> Incomparable + + GT | pA <= upper pB -> limit s $ binAny s uA tA rB + | pB >= lower pA -> let !(# s' #) = other s + in limit s' $ binAny s' uB tB lA + | otherwise -> Incomparable + + + +disjoint0 :: RadixTree a -> RadixTree b -> Bool +disjoint0 (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just _ <- mA, Just _ <- mB = False + | otherwise = True + + in mC && disjoint1 tA tB + +disjoint1 :: Radix1Tree a -> Radix1Tree b -> Bool +disjoint1 = anyAny + where + anyAny :: forall a b. Radix1Tree a -> Radix1Tree b -> Bool + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> True + + tipAny :: forall a b. UTip a -> Radix1Tree a -> Radix1Tree b -> Bool + tipAny uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip uA uB tB lenA + + else tipTip uB uA tA lenB + + Nil -> True + + tipTip :: forall a b. UTip a -> UTip b -> Radix1Tree b -> Int -> Bool + tipTip (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then if nB' == sizeofByteArray arrB + then let mC | Just _ <- mA, Just _ <- mB = False + | otherwise = True + + in mC && anyAny dA dB + + else tipAny (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = True + + binAny :: forall a b. UBin a -> Radix1Tree a -> Radix1Tree b -> Bool + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + in tipBin (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> True + + tipBin :: forall a b. UTip a -> Radix1Tree a -> UBin b -> Bool + tipBin uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = True + | otherwise = tipAny uA tA $ if wA < pB + then lB + else rB + + binBin :: forall a b. UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Bool + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> anyAny lA lB && anyAny rA rB + + LT | pB <= upper pA -> binAny uB tB rA + | pA >= lower pB -> binAny uA tA lB + | otherwise -> True + + GT | pA <= upper pB -> binAny uA tA rB + | pB >= lower pA -> binAny uB tB lA + | otherwise -> True + + + +intersection0 :: RadixTree a -> RadixTree a -> RadixTree a +intersection0 (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just _ <- mA, Just _ <- mB = mA + | otherwise = Nothing + + in RadixTree mC (intersection1 tA tB) + +intersection1 :: Radix1Tree a -> Radix1Tree a -> Radix1Tree a +intersection1 = anyAny + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> Nil + + tipAny uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip uA uB tB lenA + + else tipTip uB uA tA lenB + + Nil -> Nil + + tipTip (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just _ <- mA, Just _ <- mB = mA + | otherwise = Nothing + + in retip arrA' mC (anyAny dA dB) + + else retip arrA' Nothing $ + tipAny (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = Nil + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + in tipBin (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> Nil + + tipBin uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = Nil + | otherwise = tipAny uA tA $ if wA < pB + then lB + else rB + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> binAny uB tB rA + | pA >= lower pB -> binAny uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny uA tA rB + | pB >= lower pA -> binAny uB tB lA + | otherwise -> Nil + + + +intersectionL0 :: RadixTree a -> RadixTree b -> RadixTree a +intersectionL0 (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just _ <- mA, Just _ <- mB = mA + | otherwise = Nothing + + in RadixTree mC (intersectionL1 tA tB) + +intersectionL1 :: Radix1Tree a -> Radix1Tree b -> Radix1Tree a +intersectionL1 = + intersection_ $ \s a b -> + let !(# c #) = case s of + L -> (# a #) + R -> (# b #) + in Just c + + +intersectionWith0' :: (a -> b -> c) -> RadixTree a -> RadixTree b -> RadixTree c +intersectionWith0' f (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just a <- mA, Just b <- mB = Just $! f a b + | otherwise = Nothing + + in RadixTree mC (intersectionWith1' f tA tB) + +intersectionWith1' :: (a -> b -> c) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c +intersectionWith1' f = + intersection_ $ \s a b -> + Just $! case s of + L -> f a b + R -> f b a + +{-# INLINE intersection_ #-} +intersection_ + :: (forall x y. S x y a b -> x -> y -> Maybe c) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +intersection_ (f :: forall n o. S n o x y -> n -> o -> Maybe c) = anyAny L + where + anyAny :: forall a b. S a b x y -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> Nil + + tipAny + :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + tipAny s uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s uA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' uB uA tA lenB + + Nil -> Nil + + tipTip + :: forall a b. S a b x y -> UTip a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree c + tipTip s (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just xA <- mA, Just xB <- mB = f s xA xB + | otherwise = Nothing + + in retip arrA' mC (anyAny s dA dB) + + else retip arrA' Nothing $ + let !(# s' #) = other s + in tipAny s' (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = Nil + + binAny + :: forall a b. S a b x y -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> Nil + + tipBin :: forall a b. S a b x y -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree c + tipBin s uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = Nil + | otherwise = tipAny s uA tA $ if wA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree c + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in binAny s' uB tB rA + | pA >= lower pB -> binAny s uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny s uA tA rB + | pB >= lower pA -> let !(# s' #) = other s + in binAny s' uB tB lA + | otherwise -> Nil + + + +intersectionWithKey0' + :: (Build -> a -> b -> c) -> RadixTree a -> RadixTree b -> RadixTree c +intersectionWithKey0' f (RadixTree mA tA) (RadixTree mB tB) = + let mC | Just a <- mA, Just b <- mB = Just $! f (Build Lin) a b + | otherwise = Nothing + + in RadixTree mC $ intersectionWithKey_ + ( \s b arr vA vB -> + Just $! let b0 = Build $ Snoc b arr + in case s of + L -> f b0 vA vB + R -> f b0 vB vA + ) + tA tB + +intersectionWithKey1' + :: (Build1 -> a -> b -> c) -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c +intersectionWithKey1' f = + intersectionWithKey_ $ \s b arr vA vB -> + Just $! let b1 = Build1 $ b :/ arr + in case s of + L -> f b1 vA vB + R -> f b1 vB vA + +{-# INLINE intersectionWithKey_ #-} +intersectionWithKey_ + :: (forall x y. S x y a b -> Tsil ByteArray -> ByteArray -> x -> y -> Maybe c) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +intersectionWithKey_ + (f :: forall n o. S n o x y -> Tsil ByteArray -> ByteArray -> n -> o -> Maybe c) = + anyAny L Lin + where + anyAny + :: forall a b. S a b x y -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + anyAny s b tA tB = + case tA of + Bin pA lA rA -> binAny s b (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s b (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> Nil + + tipAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + tipAny s b uA@(# _, nA, arrA, _, _ #) tA tB = + case tB of + Bin pB lB rB -> tipBin s b uA tA (# pB, lB, rB #) + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s b uA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' b uB uA tA lenB + + Nil -> Nil + + tipTip + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree c + tipTip s b (# wA0, nA, arrA, mA, dA #) (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC | Just xA <- mA, Just xB <- mB = + f s b arrA' xA xB + + | otherwise = Nothing + + + in retip arrA' mC (anyAny s (Snoc b arrA') dA dB) + + else retip arrA' Nothing $ + let !(# s' #) = other s + in tipAny s' (Snoc b arrA') + (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | otherwise = Nil + + binAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + binAny s b uA tA tB = + case tB of + Bin pB lB rB -> binBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' b (# wB, 0, arrB, mB, dB #) tB uA + + Nil -> Nil + + tipBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree c + tipBin s b uA@(# wA, _, _, _, _ #) tA (# pB, lB, rB #) + | beyond pB wA = Nil + | otherwise = tipAny s b uA tA $ if wA < pB + then lB + else rB + + binBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree c + binBin s b uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s b lA lB) (anyAny s b rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + in binAny s' b uB tB rA + | pA >= lower pB -> binAny s b uA tA lB + | otherwise -> Nil + + GT | pA <= upper pB -> binAny s b uA tA rB + | pB >= lower pA -> let !(# s' #) = other s + in binAny s' b uB tB lA + | otherwise -> Nil + + + +{-# INLINE merge0 #-} +merge0 + :: (Build -> a -> b -> Maybe c) + -> (Build -> a -> Maybe c) + -> (Build -> Radix1Tree a -> Radix1Tree c) + -> (Build -> b -> Maybe c) + -> (Build -> Radix1Tree b -> Radix1Tree c) + -> RadixTree a + -> RadixTree b + -> RadixTree c +merge0 f oneX treeX oneY treeY = \(RadixTree mA tA) (RadixTree mB tB) -> + let mC = case mA of + Just xA -> case mB of + Just xB -> f (Build Lin) xA xB + Nothing -> oneX (Build Lin) xA + + Nothing -> case mB of + Just xB -> oneY (Build Lin) xB + Nothing -> Nothing + + in RadixTree mC $ + merge_ (\b arr -> f (Build $ Snoc b arr)) + (\b arr -> oneX (Build $ Snoc b arr)) treeX + (\b arr -> oneY (Build $ Snoc b arr)) treeY + tA tB + +{-# INLINE merge1 #-} +merge1 + :: (Build1 -> a -> b -> Maybe c) + -> (Build1 -> a -> Maybe c) + -> (Build -> Radix1Tree a -> Radix1Tree c) + -> (Build1 -> b -> Maybe c) + -> (Build -> Radix1Tree b -> Radix1Tree c) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +merge1 f oneX treeX oneY treeY = + merge_ (\b arr -> f (Build1 $ b :/ arr)) + (\b arr -> oneX (Build1 $ b :/ arr)) treeX + (\b arr -> oneY (Build1 $ b :/ arr)) treeY + +{-# INLINE merge_ #-} +merge_ + :: (Tsil ByteArray -> ByteArray -> a -> b -> Maybe c) + -> (Tsil ByteArray -> ByteArray -> a -> Maybe c) + -> (Build -> Radix1Tree a -> Radix1Tree c) + -> (Tsil ByteArray -> ByteArray -> b -> Maybe c) + -> (Build -> Radix1Tree b -> Radix1Tree c) + -> Radix1Tree a + -> Radix1Tree b + -> Radix1Tree c +merge_ (f :: Tsil ByteArray -> ByteArray -> x -> y -> Maybe c) oneX treeX oneY treeY = + anyAny L Lin + where + sideA :: forall a b. S a b x y -> Tsil ByteArray -> Radix1Tree a -> Radix1Tree c + sideA s b tA = case s of + L -> treeX (Build b) tA + R -> treeY (Build b) tA + + sideB :: forall a b. S a b x y -> Tsil ByteArray -> Radix1Tree b -> Radix1Tree c + sideB s b tB = case s of + L -> treeY (Build b) tB + R -> treeX (Build b) tB + + anyAny + :: forall a b. S a b x y -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + anyAny s b tA tB = + case tA of + Bin pA lA rA -> binAny s b (# pA, lA, rA #) tA tB + + Tip arrA mA dA -> let !wA = indexByteArray arrA 0 + in tipAny s b (# wA, 0, arrA, mA, dA #) tA tB + + Nil -> sideB s b tB + + tipAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + tipAny s b uA@(# _, nA, arrA, mA, dA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !wB = indexByteArray arrB 0 + + uB = (# wB, 0, arrB, mB, dB #) + + !lenA = sizeofByteArray arrA - nA + + !lenB = sizeofByteArray arrB + + in if lenB > lenA + then tipTip s b uA tA uB tB lenA + + else let !(# s' #) = other s + in tipTip s' b uB tB uA tA lenB + + Nil -> sideA s b $ if nA == 0 + then tA + else Tip (dropByteArray nA arrA) mA dA + + tipTip + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UTip b -> Radix1Tree b -> Int -> Radix1Tree c + tipTip s b (# wA0, nA, arrA, mA, dA #) tA (# wB0, nB, arrB, mB, dB #) tB len = + go wA0 wB0 1 + where + go wA wB !o + | wA == wB = + let !nB' = nB + o + !wB' = indexByteArray arrB nB' + + in if o >= len + then let !arrA' | nA == 0 = arrA + | otherwise = dropByteArray nA arrA + + in if nB' == sizeofByteArray arrB + then let mC = case mA of + Just xA -> + case mB of + Just xB -> case s of + L -> f b arrA' xA xB + R -> f b arrA' xB xA + + Nothing -> case s of + L -> oneX b arrA' xA + R -> oneY b arrA' xA + + Nothing -> + case mB of + Just xB -> case s of + L -> oneY b arrA' xB + R -> oneX b arrA' xB + + Nothing -> Nothing + + in retip arrA' mC (anyAny s (Snoc b arrA') dA dB) + + else let mC = case mA of + Just xA -> case s of + L -> oneX b arrA' xA + R -> oneY b arrA' xA + + Nothing -> Nothing + + in retip arrA' mC $ + let !(# s' #) = other s + in tipAny s' (Snoc b arrA') + (# wB', nB', arrB, mB, dB #) tB dA + + else let !nA' = nA + o + !wA' = indexByteArray arrA nA' + + in go wA' wB' (o + 1) + + | o == 1 = + safeJoin wA ( sideA s b $ if nA == 0 + then tA + else Tip (dropByteArray nA arrA) mA dA + ) + wB ( sideB s b $ if nB == 0 + then tB + else Tip (dropByteArray nB arrB) mB dB + ) + + | otherwise = + let !o' = o - 1 + + !(# !arrC, !arrA' #) = splitByteArray nA o' arrA + + !arrB' = dropByteArray (nB + o') arrB + + in retip arrC Nothing $ safeJoin wA (sideA s b $ Tip arrA' mA dA) + wB (sideB s b $ Tip arrB' mB dB) + + binAny + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> Radix1Tree b -> Radix1Tree c + binAny s b uA tA tB = + case tB of + Bin pB lB rB -> binBin s b uA tA (# pB, lB, rB #) tB + + Tip arrB mB dB -> let !(# s' #) = other s + + !wB = indexByteArray arrB 0 + + in tipBin s' b (# wB, 0, arrB, mB, dB #) tB uA tA + + Nil -> sideA s b tA + + tipBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UTip a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree c + tipBin s b uA@(# wA, nA, arrA, mA, dA #) tA (# pB, lB, rB #) tB + | beyond pB wA = safeJoin wA (sideA s b $ if nA == 0 + then tA + else Tip (dropByteArray nA arrA) mA dA + ) + pB (sideB s b tB) + + | wA < pB = rebin pB (tipAny s b uA tA lB) (sideB s b rB) + + | otherwise = rebin pB (sideB s b lB) (tipAny s b uA tA rB) + + binBin + :: forall a b. S a b x y -> Tsil ByteArray + -> UBin a -> Radix1Tree a -> UBin b -> Radix1Tree b -> Radix1Tree c + binBin s b uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + let {-# NOINLINE no #-} + no = safeJoin pA (sideA s b tA) pB (sideB s b tB) + + in case Prelude.compare pA pB of + EQ -> rebin pA (anyAny s b lA lB) (anyAny s b rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + + in rebin pA (sideA s b lA) (binAny s' b uB tB rA) + + | pA >= lower pB -> rebin pB (binAny s b uA tA lB) (sideB s b rB) + + | otherwise -> no + + GT | pA <= upper pB -> rebin pB (sideB s b lB) (binAny s b uA tA rB) + + | pB >= lower pA -> let !(# s' #) = other s + + in rebin pA (binAny s' b uB tB lA) (sideA s b rA) + + | otherwise -> no + + + +{-# INLINE insert0 #-} +insert0 :: Feed -> a -> RadixTree a -> RadixTree a +insert0 (Feed feed) a = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ insert_ a step w z t + Done -> RadixTree (Just a) t + +{-# INLINE insert1 #-} +insert1 :: Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insert1 (Feed1 w feed) a = + feed $ \step -> insert_ a step w + +{-# INLINE insert_ #-} +insert_ :: a -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +insert_ a step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> join + w (singleton_ step w s a) + p t + + | w < p -> Bin p (go w s l) r + | otherwise -> Bin p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> Tip arr mx (go u z' dx) + Done -> Tip arr (Just a) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> + let !(# !brr, !crr #) = splitByteArray 0 (n + 1) arr + in Tip brr (Just a) (Tip crr mx dx) + + | n == 0 = + join + (indexByteArray arr 0) t + w (singleton_ step w s a) + + | otherwise = + let !(# !brr, !crr #) = splitByteArray 0 n arr + in Tip brr Nothing $ + join + (indexByteArray crr 0) (Tip crr mx dx) + v (singleton_ step v z a) + + Nil -> singleton_ step w s a + + + +{-# INLINE insertWith0 #-} +insertWith0 :: (a -> a) -> Feed -> a -> RadixTree a -> RadixTree a +insertWith0 f (Feed feed) a = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ insertWith_ f a step w z t + Done -> + let y = case mx of + Just x -> f x + Nothing -> a + + in RadixTree (Just y) t + +{-# INLINE insertWith1 #-} +insertWith1 :: (a -> a) -> Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insertWith1 f (Feed1 w feed) a = + feed $ \step -> insertWith_ f a step w + +{-# INLINE insertWith_ #-} +insertWith_ + :: (a -> a) -> a -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +insertWith_ f a step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> join + w (singleton_ step w s a) + p t + + | w < p -> Bin p (go w s l) r + | otherwise -> Bin p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> Tip arr mx (go u z' dx) + Done -> let y = case mx of + Just x -> f x + Nothing -> a + + in Tip arr (Just y) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> + let !(# !brr, !crr #) = splitByteArray 0 (n + 1) arr + in Tip brr (Just a) (Tip crr mx dx) + + | n == 0 = + join + (indexByteArray arr 0) t + w (singleton_ step w s a) + + | otherwise = + let !(# !brr, !crr #) = splitByteArray 0 n arr + in Tip brr Nothing $ + join + (indexByteArray crr 0) (Tip crr mx dx) + v (singleton_ step v z a) + + Nil -> singleton_ step w s a + + + +{-# INLINE insertWith0' #-} +insertWith0' :: (a -> a) -> Feed -> a -> RadixTree a -> RadixTree a +insertWith0' f (Feed feed) a = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ insertWith'_ f a step w z t + Done -> + let !y = case mx of + Just x -> f x + Nothing -> a + + in RadixTree (Just y) t + +{-# INLINE insertWith1' #-} +insertWith1' :: (a -> a) -> Feed1 -> a -> Radix1Tree a -> Radix1Tree a +insertWith1' f (Feed1 w feed) a = + feed $ \step -> insertWith'_ f a step w + +{-# INLINE insertWith'_ #-} +insertWith'_ + :: (a -> a) -> a -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +insertWith'_ f a step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> join + w (singleton_ step w s $! a) + p t + + | w < p -> Bin p (go w s l) r + | otherwise -> Bin p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> Tip arr mx (go u z' dx) + Done -> let !y = case mx of + Just x -> f x + Nothing -> a + + in Tip arr (Just y) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> + let !(# !brr, !crr #) = splitByteArray 0 (n + 1) arr + in Tip brr (Just a) (Tip crr mx dx) + + | n == 0 = + join + (indexByteArray arr 0) t + w (singleton_ step w s a) + + | otherwise = + let !(# !brr, !crr #) = splitByteArray 0 n arr + in Tip brr Nothing $ + join + (indexByteArray crr 0) (Tip crr mx dx) + v (singleton_ step v z a) + + Nil -> singleton_ step w s a + + + +{-# INLINE adjust0 #-} +adjust0 :: (a -> a) -> Feed -> RadixTree a -> RadixTree a +adjust0 f (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ adjust_ f step w z t + Done -> RadixTree (fmap f mx) t + +{-# INLINE adjust1 #-} +adjust1 :: (a -> a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjust1 f (Feed1 w feed) = + feed $ \step -> adjust_ f step w + +{-# INLINE adjust_ #-} +adjust_ :: (a -> a) -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjust_ f step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> Bin p (go w s l) r + | otherwise -> Bin p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> Tip arr mx (go u z' dx) + Done -> Tip arr (fmap f mx) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> t + + | otherwise = t + + Nil -> t + + + +{-# INLINE adjust0' #-} +adjust0' :: (a -> a) -> Feed -> RadixTree a -> RadixTree a +adjust0' f (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ adjust'_ f step w z t + Done -> RadixTree (fmap' f mx) t + +{-# INLINE adjust1' #-} +adjust1' :: (a -> a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +adjust1' f (Feed1 w feed) = + feed $ \step -> adjust'_ f step w + +{-# INLINE adjust'_ #-} +adjust'_ :: (a -> a) -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +adjust'_ f step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> Bin p (go w s l) r + | otherwise -> Bin p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> Tip arr mx (go u z' dx) + Done -> Tip arr (fmap' f mx) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> t + + | otherwise = t + + Nil -> t + + + +{-# INLINE delete0 #-} +delete0 :: Feed -> RadixTree a -> RadixTree a +delete0 (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ delete_ step w z t + Done -> RadixTree Nothing t + +{-# INLINE delete1 #-} +delete1 :: Feed1 -> Radix1Tree a -> Radix1Tree a +delete1 (Feed1 w feed) = + feed $ \step -> delete_ step w + +{-# INLINE delete_ #-} +delete_ :: (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +delete_ step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> retip arr Nothing dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> t + + | otherwise = t + + Nil -> t + + + +{-# INLINE prune0 #-} +prune0 :: Openness -> Feed -> RadixTree a -> RadixTree a +prune0 openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ prune_ openness step w z t + Done -> + let my = case openness of + Open -> mx + Closed -> Nothing + + in RadixTree my Nil + +{-# INLINE prune1 #-} +prune1 :: Openness -> Feed1 -> Radix1Tree a -> Radix1Tree a +prune1 openness (Feed1 w feed) = + feed $ \step -> prune_ openness step w + +{-# INLINE prune_ #-} +prune_ :: Openness -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +prune_ openness step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> + case openness of + Open -> retip arr mx Nil + Closed -> Nil + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> Nil + + | otherwise = t + + Nil -> t + + + +{-# INLINE update0 #-} +update0 :: (a -> Maybe a) -> Feed -> RadixTree a -> RadixTree a +update0 f (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ update_ f step w z t + Done -> RadixTree (f =<< mx) t + +{-# INLINE update1 #-} +update1 :: (a -> Maybe a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +update1 f (Feed1 w feed) = + feed $ \step -> update_ f step w + +{-# INLINE update_ #-} +update_ + :: (a -> Maybe a) -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +update_ f step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> t + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> retip arr (f =<< mx) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> t + + | otherwise = t + + Nil -> t + + + +{-# INLINE alter0 #-} +alter0 :: (Maybe a -> Maybe a) -> Feed -> RadixTree a -> RadixTree a +alter0 f (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ alter_ f step w z t + Done -> RadixTree (f mx) t + +{-# INLINE alter1 #-} +alter1 :: (Maybe a -> Maybe a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +alter1 f (Feed1 w feed) = + feed $ \step -> alter_ f step w + +{-# INLINE alter_ #-} +alter_ + :: (Maybe a -> Maybe a) + -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +alter_ f step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> case f Nothing of + Nothing -> t + Just a -> join + w (singleton_ step w s a) + p t + + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + if n + 1 >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> retip arr (f mx) dx + + else case step z of + More u z' -> goarr u z' (n + 1) + Done -> + case f Nothing of + Nothing -> t + Just a -> + let !(# !brr, !crr #) = splitByteArray 0 (n + 1) arr + in Tip brr (Just a) (Tip crr mx dx) + + | otherwise = + case f Nothing of + Nothing -> t + Just a -> + if n == 0 + then join + (indexByteArray arr 0) (Tip arr mx dx) + w (singleton_ step v z a) + + else let !(# !brr, !crr #) = splitByteArray 0 n arr + in Tip brr Nothing $ + join + (indexByteArray crr 0) (Tip crr mx dx) + v (singleton_ step v z a) + + Nil -> + case f Nothing of + Nothing -> t + Just a -> singleton_ step w s a + + + +{-# INLINE shape0 #-} +shape0 :: (RadixTree a -> RadixTree a) -> Feed -> RadixTree a -> RadixTree a +shape0 f (Feed feed) = \t0@(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> RadixTree mx $ shape_ f step w z t + Done -> f t0 + +{-# INLINE shape1 #-} +shape1 :: (RadixTree a -> RadixTree a) -> Feed1 -> Radix1Tree a -> Radix1Tree a +shape1 f (Feed1 w feed) = + feed $ \step -> shape_ f step w + +{-# INLINE shape_ #-} +shape_ + :: (RadixTree a -> RadixTree a) + -> (x -> Step Word8 x) -> Word8 -> x -> Radix1Tree a -> Radix1Tree a +shape_ f step = go + where + go w s t = + case t of + Bin p l r + | beyond p w -> let !(RadixTree my dy) = f (RadixTree Nothing Nil) + in case retip (fromStep step w s) my dy of + Nil -> t + dz -> join + w dz + p t + + | w < p -> rebinL p (go w s l) r + | otherwise -> rebinR p l (go w s r) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n + | v == indexByteArray arr n = + let n' = n + 1 + in if n' >= sizeofByteArray arr + then case step z of + More u z' -> retip arr mx (go u z' dx) + Done -> let !(RadixTree my dy) = f (RadixTree mx dx) + in retip arr my dy + + else case step z of + More u z' -> goarr u z' n' + Done -> + let !(# !brr, !crr #) = splitByteArray 0 n' arr + + !(RadixTree my dy) = f (RadixTree Nothing (Tip crr mx dx)) + + in retip brr my dy + + | otherwise = + let !(RadixTree my dy) = f (RadixTree Nothing Nil) + in case retip (fromStep step v z) my dy of + Nil -> t + dz -> + if n == 0 + then join + (indexByteArray arr 0) (Tip arr mx dx) + v dz + + else let !(# !brr, !crr #) = splitByteArray 0 n arr + in Tip brr Nothing $ + join + (indexByteArray crr 0) (Tip crr mx dx) + v dz + + Nil -> + let !(RadixTree my dy) = f (RadixTree Nothing Nil) + in retip (fromStep step w s) my dy + + + +-- | Result of a tree split. +data Split l r = Split !(RadixTree l) !(RadixTree r) + +{-# INLINE splitL0 #-} +splitL0 :: Openness -> Feed -> RadixTree a -> Split a a +splitL0 openness (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + let !(# !l, !r #) = splitL_ openness step w z t + in Split (RadixTree mx l) (RadixTree Nothing r) + + Done -> + let !(# !my, !mz #) = case openness of + Open -> (# Nothing, mx #) + Closed -> (# mx, Nothing #) + + in Split (RadixTree my Nil) (RadixTree mz t) + +-- | Result of a tree split. +data Split1 l r = Split1 !(Radix1Tree l) !(Radix1Tree r) + +{-# INLINE splitL1 #-} +splitL1 :: Openness -> Feed1 -> Radix1Tree a -> Split1 a a +splitL1 openness (Feed1 w feed) = \t -> + feed $ \step s -> + case splitL_ openness step w s t of + (# !l, !r #) -> Split1 l r + +{-# INLINE splitL_ #-} +splitL_ + :: Openness -> (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> (# Radix1Tree a, Radix1Tree a #) +splitL_ openness step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let !(# !ll, !lr #) = go w s l + in (# ll, rebinL p lr r #) + + else (# Nil, t #) + + else if w <= upper p + then let !(# !rl, !rr #) = go w s r + in (# rebinR p l rl, rr #) + + else (# t, Nil #) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> + let !(# !dl, !dr #) = go u z' dx + in (# retip arr mx dl, retip arr Nothing dr #) + + Done -> + let !(# !my, !mz #) = + case openness of + Open -> (# Nil , mx #) + Closed -> (# retip arr mx Nil, Nothing #) + + in (# my, retip arr mz dx #) + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> (# Nil, t #) + + LT -> (# t, Nil #) + + GT -> (# Nil, t #) + + Nil -> (# Nil, Nil #) + + + +-- | Result of a tree split with a lookup. +data SplitLookup l x r = SplitLookup !(RadixTree l) !(Maybe x) !(RadixTree r) + +{-# INLINE splitLookup0 #-} +splitLookup0 :: Feed -> RadixTree a -> SplitLookup a a a +splitLookup0 (Feed feed) = \(RadixTree mx t) -> + feed $ \step s -> + case step s of + More w z -> + let !(# !l, !my, !r #) = splitLookup_ step w z t + in SplitLookup (RadixTree mx l) my (RadixTree Nothing r) + + Done -> SplitLookup (RadixTree Nothing Nil) mx (RadixTree Nothing t) + +-- | Result of a tree split with a lookup. +data SplitLookup1 l x r = SplitLookup1 !(Radix1Tree l) !(Maybe x) !(Radix1Tree r) + +{-# INLINE splitLookup1 #-} +splitLookup1 :: Feed1 -> Radix1Tree a -> SplitLookup1 a a a +splitLookup1 (Feed1 w feed) = \t -> + feed $ \step s -> + case splitLookup_ step w s t of + (# !l, !mx, !r #) -> SplitLookup1 l mx r + +{-# INLINE splitLookup_ #-} +splitLookup_ + :: (x -> Step Word8 x) + -> Word8 -> x -> Radix1Tree a -> (# Radix1Tree a, Maybe a, Radix1Tree a #) +splitLookup_ step = go + where + go w s t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then let !(# !ll, !my, !lr #) = go w s l + in (# ll, my, rebinL p lr r #) + + else (# Nil, Nothing, t #) + + else if w <= upper p + then let !(# !rl, !my, !rr #) = go w s r + in (# rebinR p l rl, my, rr #) + + else (# t, Nothing, Nil #) + + Tip arr mx dx -> goarr w s 0 + where + goarr v z n = + let n' = n + 1 + in case indexByteArray arr n `compare` v of + EQ | n' >= sizeofByteArray arr -> + case step z of + More u z' -> + let !(# !dl, !my, !dr #) = go u z' dx + in (# retip arr mx dl, my, retip arr Nothing dr #) + + Done -> + (# Nil, mx, retip arr Nothing dx #) + + | otherwise -> + case step z of + More u z' -> goarr u z' n' + Done -> (# Nil, Nothing, t #) + + LT -> (# t, Nothing, Nil #) + + GT -> (# Nil, Nothing, t #) + + Nil -> (# Nil, Nothing, Nil #) + + + +{-# INLINE filterMaybe #-} +filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a +filterMaybe f mx = + case mx of + Just x | f x -> Just x + _ -> Nothing + +filter0 :: (a -> Bool) -> RadixTree a -> RadixTree a +filter0 f (RadixTree mx t) = RadixTree (filterMaybe f mx) (filter1 f t) + +filter1 :: (a -> Bool) -> Radix1Tree a -> Radix1Tree a +filter1 f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + Tip arr mx dx -> retip arr (filterMaybe f mx) (go dx) + Nil -> Nil + + + +filterWithKey0 :: (Build -> a -> Bool) -> RadixTree a -> RadixTree a +filterWithKey0 f (RadixTree mx t) = + RadixTree (filterMaybe (f (Build Lin)) mx) $ + filterWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +filterWithKey1 :: (Build1 -> a -> Bool) -> Radix1Tree a -> Radix1Tree a +filterWithKey1 f = filterWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE filterWithKey_ #-} +filterWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Bool) -> Radix1Tree a -> Radix1Tree a +filterWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> rebin p (go b l) (go b r) + + Tip arr mx dx -> retip arr (filterMaybe (f b arr) mx) (go (Snoc b arr) dx) + + Nil -> Nil + + + +mapMaybe0 :: (a -> Maybe b) -> RadixTree a -> RadixTree b +mapMaybe0 f (RadixTree mx t) = RadixTree (f =<< mx) (mapMaybe1 f t) + +mapMaybe1 :: (a -> Maybe b) -> Radix1Tree a -> Radix1Tree b +mapMaybe1 f = go + where + go t = + case t of + Bin p l r -> rebin p (go l) (go r) + Tip arr mx dx -> retip arr (f =<< mx) (go dx) + Nil -> Nil + + + +mapMaybeWithKey0 :: (Build -> a -> Maybe b) -> RadixTree a -> RadixTree b +mapMaybeWithKey0 f (RadixTree mx t) = + RadixTree (f (Build Lin) =<< mx) $ + mapMaybeWithKey_ (\b arr -> f (Build $ Snoc b arr)) Lin t + +mapMaybeWithKey1 :: (Build1 -> a -> Maybe b) -> Radix1Tree a -> Radix1Tree b +mapMaybeWithKey1 f = mapMaybeWithKey_ (\b arr -> f (Build1 $ b :/ arr)) Lin + +{-# INLINE mapMaybeWithKey_ #-} +mapMaybeWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe b) -> Tsil ByteArray + -> Radix1Tree a -> Radix1Tree b +mapMaybeWithKey_ f = go + where + go b t = + case t of + Bin p l r -> rebin p (go b l) (go b r) + + Tip arr mx dx -> retip arr (f b arr =<< mx) (go (Snoc b arr) dx) + + Nil -> Nil + + + +partition0 :: (a -> Bool) -> RadixTree a -> Split a a +partition0 f = \(RadixTree mx t) -> + let !(# !l, !r #) = partition_ f t + + !(# !my, !mz #) = + case mx of + Just x + | f x -> (# mx , Nothing #) + | otherwise -> (# Nothing, mx #) + + Nothing -> (# Nothing, Nothing #) + + in Split (RadixTree my l) (RadixTree mz r) + +partition1 :: (a -> Bool) -> Radix1Tree a -> Split1 a a +partition1 f = \t -> + case partition_ f t of + (# !l, !r #) -> Split1 l r + +partition_ :: (a -> Bool) -> Radix1Tree a -> (# Radix1Tree a, Radix1Tree a #) +partition_ f = go + where + go t = + case t of + Bin p l r -> + let !(# !ly, !lz #) = go l + !(# !ry, !rz #) = go r + + in (# rebin p ly ry, rebin p lz rz #) + + Tip arr mx dx -> + let !(# !dy, !dz #) = go dx + in case mx of + Nothing -> (# retip arr Nothing dy, retip arr Nothing dz #) + Just x -> + if f x + then (# Tip arr (Just x) dy, retip arr Nothing dz #) + else (# retip arr Nothing dy, Tip arr (Just x) dz #) + + Nil -> (# Nil, Nil #) + + + +partitionWithKey0 :: (Build -> a -> Bool) -> RadixTree a -> Split a a +partitionWithKey0 f = \(RadixTree mx t) -> + let !(# !l, !r #) = partitionWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + + !(# !my, !mz #) = + case mx of + Just x + | f (Build Lin) x -> (# mx , Nothing #) + | otherwise -> (# Nothing, mx #) + + Nothing -> (# Nothing, Nothing #) + + in Split (RadixTree my l) (RadixTree mz r) + +partitionWithKey1 :: (Build1 -> a -> Bool) -> Radix1Tree a -> Split1 a a +partitionWithKey1 f = \t -> + case partitionWithKey_ (\b arr -> f (Build1 $ b :/ arr)) t of + (# !l, !r #) -> Split1 l r + +{-# INLINE partitionWithKey_ #-} +partitionWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Bool) + -> Radix1Tree a -> (# Radix1Tree a, Radix1Tree a #) +partitionWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> + let !(# !ly, !lz #) = go b l + !(# !ry, !rz #) = go b r + + in (# rebin p ly ry, rebin p lz rz #) + + Tip arr mx dx -> + let !(# !dy, !dz #) = go (Snoc b arr) dx + in case mx of + Nothing -> (# retip arr Nothing dy, retip arr Nothing dz #) + Just x -> + if f b arr x + then (# Tip arr (Just x) dy, retip arr Nothing dz #) + else (# retip arr Nothing dy, Tip arr (Just x) dz #) + + Nil -> (# Nil, Nil #) + + + +mapEither0 :: (a -> Either b c) -> RadixTree a -> Split b c +mapEither0 f = \(RadixTree mx t) -> + let !(# !l, !r #) = mapEither_ f t + + !(# !my, !mz #) = + case mx of + Just x -> + case f x of + Left y -> (# Just y , Nothing #) + Right z -> (# Nothing, Just z #) + + Nothing -> (# Nothing, Nothing #) + + in Split (RadixTree my l) (RadixTree mz r) + +mapEither1 :: (a -> Either b c) -> Radix1Tree a -> Split1 b c +mapEither1 f = \t -> + case mapEither_ f t of + (# !l, !r #) -> Split1 l r + +mapEither_ :: (a -> Either b c) -> Radix1Tree a -> (# Radix1Tree b, Radix1Tree c #) +mapEither_ f = go + where + go t = + case t of + Bin p l r -> + let !(# !ly, !lz #) = go l + !(# !ry, !rz #) = go r + + in (# rebin p ly ry, rebin p lz rz #) + + Tip arr mx dx -> + let !(# !dy, !dz #) = go dx + in case mx of + Nothing -> (# retip arr Nothing dy, retip arr Nothing dz #) + Just x -> + case f x of + Left y -> (# Tip arr (Just y) dy, retip arr Nothing dz #) + Right z -> (# retip arr Nothing dy, Tip arr (Just z) dz #) + + Nil -> (# Nil, Nil #) + + + +mapEitherWithKey0 :: (Build -> a -> Either b c) -> RadixTree a -> Split b c +mapEitherWithKey0 f = \(RadixTree mx t) -> + let !(# !l, !r #) = mapEitherWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + + !(# !my, !mz #) = + case mx of + Just x -> + case f (Build Lin) x of + Left y -> (# Just y , Nothing #) + Right z -> (# Nothing, Just z #) + + Nothing -> (# Nothing, Nothing #) + + in Split (RadixTree my l) (RadixTree mz r) + +mapEitherWithKey1 :: (Build1 -> a -> Either b c) -> Radix1Tree a -> Split1 b c +mapEitherWithKey1 f = \t -> + case mapEitherWithKey_ (\b arr -> f (Build1 $ b :/ arr)) t of + (# !l, !r #) -> Split1 l r + +{-# INLINE mapEitherWithKey_ #-} +mapEitherWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Either b c) + -> Radix1Tree a -> (# Radix1Tree b, Radix1Tree c #) +mapEitherWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> + let !(# !ly, !lz #) = go b l + !(# !ry, !rz #) = go b r + + in (# rebin p ly ry, rebin p lz rz #) + + Tip arr mx dx -> + let !(# !dy, !dz #) = go (Snoc b arr) dx + in case mx of + Nothing -> (# retip arr Nothing dy, retip arr Nothing dz #) + Just x -> + case f b arr x of + Left y -> (# Tip arr (Just y) dy, retip arr Nothing dz #) + Right z -> (# retip arr Nothing dy, Tip arr (Just z) dz #) + + Nil -> (# Nil, Nil #) + + + +moduleLoc1 :: String +moduleLoc1 = "Radix1Tree.Word8.Strict" + + + +lookupMin0 :: RadixTree a -> Maybe a +lookupMin0 (RadixTree mx t) = + case mx of + Just x -> Just x + Nothing -> lookupMin1 t + +lookupMin1 :: Radix1Tree a -> Maybe a +lookupMin1 Nil = Nothing +lookupMin1 t = let !(# a #) = unsafeLookupMin1 t + in Just a + +unsafeLookupMin1 :: Radix1Tree a -> (# a #) +unsafeLookupMin1 t = + case t of + Bin _ l _ -> unsafeLookupMin1 l + Tip _ mx dx -> case mx of + Just x -> (# x #) + Nothing -> unsafeLookupMin1 dx + + Nil -> throw $ MalformedTree moduleLoc1 "lookupMin" + + + +lookupMinWithKey0 :: RadixTree a -> Maybe (Lookup a) +lookupMinWithKey0 (RadixTree mx t) = + case mx of + Just x -> Just (Lookup (Build Lin) x) + Nothing -> + case t of + Nil -> Nothing + _ -> let !(# b, arr, a #) = unsafeLookupMinWithKey_ Lin t + in Just $! Lookup (Build $ Snoc b arr) a + +lookupMinWithKey1 :: Radix1Tree a -> Maybe (Lookup1 a) +lookupMinWithKey1 Nil = Nothing +lookupMinWithKey1 t = Just $! unsafeLookupMinWithKey1 t + +unsafeLookupMinWithKey1 :: Radix1Tree a -> Lookup1 a +unsafeLookupMinWithKey1 t = + let !(# b, arr, a #) = unsafeLookupMinWithKey_ Lin t + in Lookup1 (Build1 $ b :/ arr) a + +unsafeLookupMinWithKey_ + :: Tsil ByteArray -> Radix1Tree a -> (# Tsil ByteArray, ByteArray, a #) +unsafeLookupMinWithKey_ = go + where + go b t = + case t of + Bin _ l _ -> go b l + Tip arr mx dx -> case mx of + Just x -> (# b, arr, x #) + Nothing -> go (Snoc b arr) dx + + Nil -> throw $ MalformedTree moduleLoc1 "lookupMinWithKey" + + + +lookupMax0 :: RadixTree a -> Maybe a +lookupMax0 (RadixTree mx t) = + case t of + Nil -> mx + _ -> let !(# a #) = unsafeLookupMax1 t + in Just a + +lookupMax1 :: Radix1Tree a -> Maybe a +lookupMax1 Nil = Nothing +lookupMax1 t = let !(# a #) = unsafeLookupMax1 t + in Just a + +unsafeLookupMax1 :: Radix1Tree a -> (# a #) +unsafeLookupMax1 t = + case t of + Bin _ _ r -> unsafeLookupMax1 r + Tip _ mx dx -> case dx of + Nil | Just x <- mx -> (# x #) + _ -> unsafeLookupMax1 dx + + Nil -> throw $ MalformedTree moduleLoc1 "lookupMin" + + + +lookupMaxWithKey0 :: RadixTree a -> Maybe (Lookup a) +lookupMaxWithKey0 (RadixTree mx t) = + case t of + Nil -> Lookup (Build Lin) `fmap'` mx + _ -> let !(# b, arr, a #) = unsafeLookupMaxWithKey_ Lin t + in Just $! Lookup (Build $ Snoc b arr) a + +lookupMaxWithKey1 :: Radix1Tree a -> Maybe (Lookup1 a) +lookupMaxWithKey1 Nil = Nothing +lookupMaxWithKey1 t = Just $! unsafeLookupMaxWithKey1 t + +unsafeLookupMaxWithKey1 :: Radix1Tree a -> Lookup1 a +unsafeLookupMaxWithKey1 t = + let !(# b, arr, a #) = unsafeLookupMaxWithKey_ Lin t + in Lookup1 (Build1 $ b :/ arr) a + +unsafeLookupMaxWithKey_ + :: Tsil ByteArray -> Radix1Tree a -> (# Tsil ByteArray, ByteArray, a #) +unsafeLookupMaxWithKey_ = go + where + go b t = + case t of + Bin _ _ r -> go b r + Tip arr mx dx -> case dx of + Nil | Just x <- mx -> (# b, arr, x #) + _ -> go (Snoc b arr) dx + + Nil -> throw $ MalformedTree moduleLoc1 "lookupMaxWithKey" + + + +deleteMin0 :: RadixTree a -> RadixTree a +deleteMin0 (RadixTree mx t) = + case mx of + Just _ -> RadixTree Nothing t + Nothing -> RadixTree mx (deleteMin1 t) + +deleteMin1 :: Radix1Tree a -> Radix1Tree a +deleteMin1 Nil = Nil +deleteMin1 r = unsafeDeleteMin1 r + +unsafeDeleteMin1 :: Radix1Tree a -> Radix1Tree a +unsafeDeleteMin1 = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + + Tip arr mx dx -> case mx of + Nothing -> retip arr mx (go dx) + Just _ -> retip arr Nothing dx + + Nil -> Nil + + + +deleteMax0 :: RadixTree a -> RadixTree a +deleteMax0 t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just _ -> RadixTree Nothing t + Nothing -> t0 + + _ -> RadixTree mx (unsafeDeleteMax1 t) + +deleteMax1 :: Radix1Tree a -> Radix1Tree a +deleteMax1 Nil = Nil +deleteMax1 r = unsafeDeleteMax1 r + +unsafeDeleteMax1 :: Radix1Tree a -> Radix1Tree a +unsafeDeleteMax1 = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + + Tip arr mx dx -> case dx of + Nil -> Nil + _ -> retip arr mx (go dx) + + Nil -> Nil + + + +adjustMin0 :: (a -> a) -> RadixTree a -> RadixTree a +adjustMin0 f (RadixTree mx t) = + case mx of + Just x -> RadixTree (Just $ f x) t + Nothing -> RadixTree mx (adjustMin1 f t) + +adjustMin1 :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMin1 _ Nil = Nil +adjustMin1 f r = unsafeAdjustMin1 f r + +unsafeAdjustMin1 :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMin1 f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) r + + Tip arr mx dx -> case mx of + Just x -> Tip arr (Just $ f x) dx + Nothing -> Tip arr mx (go dx) + + Nil -> Nil + + + +adjustMin0' :: (a -> a) -> RadixTree a -> RadixTree a +adjustMin0' f (RadixTree mx t) = + case mx of + Just x -> RadixTree (Just $! f x) t + Nothing -> RadixTree mx (adjustMin1' f t) + +adjustMin1' :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMin1' _ Nil = Nil +adjustMin1' f r = unsafeAdjustMin1' f r + +unsafeAdjustMin1' :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMin1' f = go + where + go t = + case t of + Bin p l r -> Bin p (go l) r + + Tip arr mx dx -> case mx of + Just x -> Tip arr (Just $! f x) dx + Nothing -> Tip arr mx (go dx) + + Nil -> Nil + + + +adjustMinWithKey0 :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMinWithKey0 f (RadixTree mx t) = + case mx of + Just x -> RadixTree (Just $ f (Build Lin) x) t + Nothing -> RadixTree mx $ + case t of + Nil -> Nil + _ -> unsafeAdjustMinWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +adjustMinWithKey1 :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMinWithKey1 _ Nil = Nil +adjustMinWithKey1 f r = unsafeAdjustMinWithKey1 f r + +unsafeAdjustMinWithKey1 :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMinWithKey1 f = unsafeAdjustMinWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeAdjustMinWithKey_ #-} +unsafeAdjustMinWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMinWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> Bin p (go b l) r + + Tip arr mx dx -> case mx of + Just x -> Tip arr (Just $ f b arr x) dx + Nothing -> Tip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +adjustMinWithKey0' :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMinWithKey0' f (RadixTree mx t) = + case mx of + Just x -> RadixTree (Just $! f (Build Lin) x) t + Nothing -> RadixTree mx $ + case t of + Nil -> Nil + _ -> unsafeAdjustMinWithKey'_ (\b arr -> f (Build $ Snoc b arr)) t + +adjustMinWithKey1' :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMinWithKey1' _ Nil = Nil +adjustMinWithKey1' f r = unsafeAdjustMinWithKey1' f r + +unsafeAdjustMinWithKey1' :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMinWithKey1' f = unsafeAdjustMinWithKey'_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeAdjustMinWithKey'_ #-} +unsafeAdjustMinWithKey'_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMinWithKey'_ f = go Lin + where + go b t = + case t of + Bin p l r -> Bin p (go b l) r + + Tip arr mx dx -> case mx of + Just x -> Tip arr (Just $! f b arr x) dx + Nothing -> Tip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +adjustMax0 :: (a -> a) -> RadixTree a -> RadixTree a +adjustMax0 f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (Just $ f x) t + Nothing -> t0 + + _ -> RadixTree mx (unsafeAdjustMax1 f t) + +adjustMax1 :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMax1 _ Nil = Nil +adjustMax1 f r = unsafeAdjustMax1 f r + +unsafeAdjustMax1 :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMax1 f = go + where + go t = + case t of + Bin p l r -> Bin p l (go r) + + Tip arr mx dx -> case dx of + Nil | Just x <- mx -> Tip arr (Just $ f x) dx + _ -> Tip arr mx (go dx) + + Nil -> Nil + + + +adjustMax0' :: (a -> a) -> RadixTree a -> RadixTree a +adjustMax0' f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (Just $! f x) t + Nothing -> t0 + + _ -> RadixTree mx (unsafeAdjustMax1 f t) + +adjustMax1' :: (a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMax1' _ Nil = Nil +adjustMax1' f r = unsafeAdjustMax1' f r + +unsafeAdjustMax1' :: (a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMax1' f = go + where + go t = + case t of + Bin p l r -> Bin p l (go r) + + Tip arr mx dx -> case dx of + Nil | Just x <- mx -> Tip arr (Just $! f x) dx + _ -> Tip arr mx (go dx) + + Nil -> Nil + + + +adjustMaxWithKey0 :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMaxWithKey0 f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (Just $ f (Build Lin) x) t + Nothing -> t0 + + _ -> RadixTree mx $ + unsafeAdjustMaxWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +adjustMaxWithKey1 :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMaxWithKey1 _ Nil = Nil +adjustMaxWithKey1 f r = unsafeAdjustMaxWithKey1 f r + +unsafeAdjustMaxWithKey1 :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMaxWithKey1 f = unsafeAdjustMaxWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeAdjustMaxWithKey_ #-} +unsafeAdjustMaxWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMaxWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> Bin p l (go b r) + + Tip arr mx dx -> + case dx of + Nil | Just x <- mx -> Tip arr (Just $ f b arr x) dx + _ -> Tip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +adjustMaxWithKey0' :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMaxWithKey0' f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (Just $! f (Build Lin) x) t + Nothing -> t0 + + _ -> RadixTree mx $ + unsafeAdjustMaxWithKey'_ (\b arr -> f (Build $ Snoc b arr)) t + +adjustMaxWithKey1' :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +adjustMaxWithKey1' _ Nil = Nil +adjustMaxWithKey1' f r = unsafeAdjustMaxWithKey1' f r + +unsafeAdjustMaxWithKey1' :: (Build1 -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMaxWithKey1' f = unsafeAdjustMaxWithKey'_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeAdjustMaxWithKey'_ #-} +unsafeAdjustMaxWithKey'_ + :: (Tsil ByteArray -> ByteArray -> a -> a) -> Radix1Tree a -> Radix1Tree a +unsafeAdjustMaxWithKey'_ f = go Lin + where + go b t = + case t of + Bin p l r -> Bin p l (go b r) + + Tip arr mx dx -> + case dx of + Nil | Just x <- mx -> Tip arr (Just $! f b arr x) dx + _ -> Tip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +updateMin0 :: (a -> Maybe a) -> RadixTree a -> RadixTree a +updateMin0 f (RadixTree mx t) = + case mx of + Just x -> RadixTree (f x) t + Nothing -> RadixTree mx (updateMin1 f t) + +updateMin1 :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMin1 _ Nil = Nil +updateMin1 f r = unsafeUpdateMin1 f r + +unsafeUpdateMin1 :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMin1 f = go + where + go t = + case t of + Bin p l r -> rebinL p (go l) r + + Tip arr mx dx -> case mx of + Just x -> retip arr (f x) dx + Nothing -> retip arr mx (go dx) + + Nil -> Nil + + + +updateMinWithKey0 :: (Build -> a -> Maybe a) -> RadixTree a -> RadixTree a +updateMinWithKey0 f (RadixTree mx t) = + case mx of + Just x -> RadixTree (f (Build Lin) x) t + Nothing -> RadixTree mx $ + case t of + Nil -> Nil + _ -> unsafeUpdateMinWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +updateMinWithKey1 :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMinWithKey1 _ Nil = Nil +updateMinWithKey1 f r = unsafeUpdateMinWithKey1 f r + +unsafeUpdateMinWithKey1 :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMinWithKey1 f = unsafeUpdateMinWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeUpdateMinWithKey_ #-} +unsafeUpdateMinWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMinWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> rebinL p (go b l) r + + Tip arr mx dx -> case mx of + Just x -> retip arr (f b arr x) dx + Nothing -> retip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +updateMax0 :: (a -> Maybe a) -> RadixTree a -> RadixTree a +updateMax0 f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (f x) t + Nothing -> t0 + + _ -> RadixTree mx (unsafeUpdateMax1 f t) + +updateMax1 :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMax1 _ Nil = Nil +updateMax1 f r = unsafeUpdateMax1 f r + +unsafeUpdateMax1 :: (a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMax1 f = go + where + go t = + case t of + Bin p l r -> rebinR p l (go r) + + Tip arr mx dx -> case dx of + Nil | Just x <- mx -> retip arr (f x) dx + _ -> retip arr mx (go dx) + + Nil -> Nil + + + +updateMaxWithKey0 :: (Build -> a -> Maybe a) -> RadixTree a -> RadixTree a +updateMaxWithKey0 f t0@(RadixTree mx t) = + case t of + Nil -> case mx of + Just x -> RadixTree (f (Build Lin) x) t + Nothing -> t0 + + _ -> RadixTree mx $ + unsafeUpdateMaxWithKey_ (\b arr -> f (Build $ Snoc b arr)) t + +updateMaxWithKey1 :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +updateMaxWithKey1 _ Nil = Nil +updateMaxWithKey1 f r = unsafeUpdateMaxWithKey1 f r + +unsafeUpdateMaxWithKey1 :: (Build1 -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMaxWithKey1 f = unsafeUpdateMaxWithKey_ (\b arr -> f (Build1 $ b :/ arr)) + +{-# INLINE unsafeUpdateMaxWithKey_ #-} +unsafeUpdateMaxWithKey_ + :: (Tsil ByteArray -> ByteArray -> a -> Maybe a) -> Radix1Tree a -> Radix1Tree a +unsafeUpdateMaxWithKey_ f = go Lin + where + go b t = + case t of + Bin p l r -> rebinR p l (go b r) + + Tip arr mx dx -> case dx of + Nil | Just x <- mx -> retip arr (f b arr x) dx + _ -> retip arr mx (go (Snoc b arr) dx) + + Nil -> Nil + + + +-- | The leftmost value with its key and the rest of the tree. +data ViewL a = ViewL !Build a !(RadixTree a) + deriving Show + +minView0 :: RadixTree a -> Maybe (ViewL a) +minView0 (RadixTree mx t) = + case mx of + Just x -> Just $! ViewL (Build Lin) x (RadixTree Nothing t) + Nothing -> + case t of + Nil -> Nothing + _ -> Just $! let !(# !b, !arr, x, !t' #) = unsafeMinView_ t + in ViewL (Build $ Snoc b arr) x (RadixTree mx t') + + +-- | The leftmost value with its key and the rest of the tree. +data ViewL1 a = ViewL1 !Build1 a !(Radix1Tree a) + deriving Show + +minView1 :: Radix1Tree a -> Maybe (ViewL1 a) +minView1 Nil = Nothing +minView1 t = Just $! unsafeMinView1 t + +unsafeMinView1 :: Radix1Tree a -> ViewL1 a +unsafeMinView1 t = + let !(# !b, !arr, x, !t' #) = unsafeMinView_ t + in ViewL1 (Build1 $ b :/ arr) x t' + +unsafeMinView_ :: Radix1Tree a -> (# Tsil ByteArray, ByteArray, a, Radix1Tree a #) +unsafeMinView_ = go Lin + where + go b t = + case t of + Bin p l r -> + let !(# !b', !brr, z, !l' #) = go b l + in (# b', brr, z, rebinL p l' r #) + + Tip arr mx dx -> + case mx of + Just x -> (# b, arr, x, retip arr Nothing dx #) + Nothing -> + let !(# !b', !brr, z, !dy #) = go (Snoc b arr) dx + in (# b', brr, z, retip arr mx dy #) + + Nil -> throw $ MalformedTree moduleLoc1 "minView" + + + +-- | The rightmost value with its key and the rest of the tree. +data ViewR a = ViewR !(RadixTree a) !Build a + deriving Show + +maxView0 :: RadixTree a -> Maybe (ViewR a) +maxView0 (RadixTree mx t) = + case t of + Nil -> ViewR (RadixTree Nothing t) (Build Lin) `fmap'` mx + _ -> Just $! let !(# !t', !b, !arr, x #) = unsafeMaxView_ t + in ViewR (RadixTree mx t') (Build $ Snoc b arr) x + + +-- | The rightmost value with its key and the rest of the tree. +data ViewR1 a = ViewR1 !(Radix1Tree a) !Build1 a + deriving Show + +maxView1 :: Radix1Tree a -> Maybe (ViewR1 a) +maxView1 Nil = Nothing +maxView1 t = Just $! unsafeMaxView1 t + +unsafeMaxView1 :: Radix1Tree a -> ViewR1 a +unsafeMaxView1 t = + let !(# !t', !b, !arr, x #) = unsafeMaxView_ t + in ViewR1 t' (Build1 $ b :/ arr) x + +unsafeMaxView_ :: Radix1Tree a -> (# Radix1Tree a, Tsil ByteArray, ByteArray, a #) +unsafeMaxView_ = go Lin + where + go b t = + case t of + Bin p l r -> + let !(# !r', !b', !brr, z #) = go b r + in (# rebinR p l r', b', brr, z #) + + Tip arr mx dx -> + case dx of + Nil | Just x <- mx -> (# retip arr Nothing dx, b, arr, x #) + _ -> + let !(# !dy, !b', !brr, z #) = go (Snoc b arr) dx + in (# retip arr mx dy, b', brr, z #) + + Nil -> throw $ MalformedTree moduleLoc1 "maxView" diff --git a/src/Data/RadixNTree/Word8/Strict/Debug.hs b/src/Data/RadixNTree/Word8/Strict/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Strict/Debug.hs @@ -0,0 +1,109 @@ +module Data.RadixNTree.Word8.Strict.Debug + ( showsTree0 + , showsTree1 + + , Validity (..) + , Reason (..) + , validate0 + , validate1 + ) where + +import Data.ByteArray.NonEmpty +import Data.RadixNTree.Word8.Debug +import Data.RadixNTree.Word8.Key +import Data.RadixNTree.Word8.Strict +import Numeric.Long +import Radix.Word8.Debug + +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Primitive.ByteArray + + + +showsTree0 :: (a -> ShowS) -> RadixTree a -> ShowS +showsTree0 f (RadixTree mx t) = + showString "RadixTree" . case mx of + Just x -> showString " => " . f x + Nothing -> id + + . showChar '\n' + + . showsTree_ 2 f t + +showsTree1 :: (a -> ShowS) -> Radix1Tree a -> ShowS +showsTree1 f = showsTree_ 0 f + +showsTree_ :: Int -> (a -> ShowS) -> Radix1Tree a -> ShowS +showsTree_ n0 f = go n0 + where + go i t = + mappend (replicate i ' ') . + case t of + Bin p l r -> + showString "Bin " . showPrefix p . showChar '\n' + . go (i + 2) l . showChar '\n' + . go (i + 2) r + + Tip arr mx dx -> + showString "Tip " . if sizeofByteArray arr <= 0 + then id + else let w0 :| ws = toNonEmpty arr + in showLongBin w0 + . showString " (" . showLongHex w0 . showChar ')' + . foldr (\x s -> showChar ' ' . showLongHex x . s) id ws + + . case mx of + Just x -> showString " => " . f x + Nothing -> id + + . showChar '\n' + + . go (i + 2) dx + + Nil -> showString "Nil" + + + +validate0 :: RadixTree a -> Validity +validate0 (RadixTree _ t) = validate1 t + +validate1 :: Radix1Tree a -> Validity +validate1 = go Lin + where + go b t = + case t of + Bin p l r + | p == 0 -> Invalid (Build b) ZeroPrefix + | 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 + | Nothing <- mx, Tip _ _ _ <- dx -> Invalid (Build b) UncompressedTip + | Nothing <- mx, Nil <- dx -> Invalid (Build b) UncompressedTip + | otherwise -> go (Snoc b arr) dx + + Nil -> Valid + + 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 -> + 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) -> + Invalid (Build b) $ KeyBelow q (indexByteArray arr 0) + + | Nothing <- mx, Tip _ _ _ <- dx -> Invalid (Build b) UncompressedTip + | Nothing <- mx, Nil <- dx -> Invalid (Build b) UncompressedTip + | otherwise -> go (Snoc b arr) dx + + Nil -> Invalid (Build b) $ MalformedBin q diff --git a/src/Data/RadixNTree/Word8/Strict/TH.hs b/src/Data/RadixNTree/Word8/Strict/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixNTree/Word8/Strict/TH.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +module Data.RadixNTree.Word8.Strict.TH + ( RadixTree + , sequenceCode0 + + , Radix1Tree + , sequenceCode1 + ) where + +import Data.RadixNTree.Word8.Strict + +import Language.Haskell.TH.Syntax + + + +sequenceCode0 :: Quote m => RadixTree (Code m a) -> Code m (RadixTree a) +sequenceCode0 (RadixTree mx t) = + [|| RadixTree $$(sequenceMaybe mx) $$(sequenceCode1 t) ||] + +sequenceCode1 :: Quote m => Radix1Tree (Code m a) -> Code m (Radix1Tree a) +sequenceCode1 t = + case t of + Bin p l r -> + [|| Bin + p + $$(sequenceCode1 l) + $$(sequenceCode1 r) + ||] + + Tip arr mx dx -> [|| Tip arr $$(sequenceMaybe mx) $$(sequenceCode1 dx) ||] + + Nil -> [|| Nil ||] + + + +sequenceMaybe :: Quote m => Maybe (Code m a) -> Code m (Maybe a) +sequenceMaybe mx = + case mx of + Just x -> [|| Just $$(x) ||] + Nothing -> [|| Nothing ||] diff --git a/src/Data/RadixTree.hs b/src/Data/RadixTree.hs deleted file mode 100644 --- a/src/Data/RadixTree.hs +++ /dev/null @@ -1,33 +0,0 @@ ----------------------------------------------------------------------------- --- | --- Module : Data.RadixTree --- Copyright : (c) Sergey Vinokurov 2018 --- License : BSD3-style (see LICENSE) --- Maintainer : serg.foo@gmail.com --- --- This is an implementation of the radix tree datastructure. Interface --- is designed to be compatible with what 'Data.Map' provides. ----------------------------------------------------------------------------- - -module Data.RadixTree - ( RadixTree - , empty - , null - , size - , insert - , insertWith - , lookup - , fromList - , toList - , toAscList - , keys - , keysSet - , elems - , mapMaybe - , union - , unionWith - ) where - -import Prelude hiding (lookup, null) - -import Data.RadixTree.Internal diff --git a/src/Data/RadixTree/Internal.hs b/src/Data/RadixTree/Internal.hs deleted file mode 100644 --- a/src/Data/RadixTree/Internal.hs +++ /dev/null @@ -1,454 +0,0 @@ ----------------------------------------------------------------------------- --- | --- Module : Data.RadixTree.Internal --- Copyright : (c) Sergey Vinokurov 2018 --- License : BSD3-style (see LICENSE) --- Maintainer : serg.foo@gmail.com --- --- This is an internal module that exposes innards of the 'RadixTree' --- data structure. This API may change in any new release, even in a --- patch release - depend on it at your own risk. ----------------------------------------------------------------------------- - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_HADDOCK not-home #-} - -module Data.RadixTree.Internal - ( RadixTree(..) - , empty - , null - , size - , insert - , insertWith - , lookup - , fromList - , toList - , toAscList - , keys - , keysSet - , elems - , mapMaybe - , union - , unionWith - ) where - -import Prelude hiding (lookup, null) - -import Control.Arrow (first) -import Control.DeepSeq -import Control.Monad.ST -import Control.Monad.ST.Unsafe - -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as BSS -import qualified Data.ByteString.Short.Internal as BSSI -import qualified Data.Foldable as Foldable -import Data.IntMap (IntMap) -import qualified Data.IntMap.Strict as IM -import qualified Data.List as L -import Data.Maybe (fromMaybe) -import Data.Primitive.ByteArray -import Data.Semigroup as Semigroup -import Data.Set (Set) -import qualified Data.Set as S -import Data.Word -import GHC.Generics (Generic) - --- | A tree data structure that efficiently indexes values by string keys. --- --- This type can be more memory-efficient than 'Data.Map' because it combines --- common prefixes of all keys. Specific savings will vary depending on --- concrete data set. -data RadixTree a - = RadixNode - !(Maybe a) - !(IntMap (RadixTree a)) -- ^ Either has 0 or 2 or more children, never 1. - | RadixStr - !(Maybe a) - {-# UNPACK #-} !ShortByteString -- ^ Non-empty - !(RadixTree a) - deriving (Show, Functor, Foldable, Traversable, Generic) - -instance NFData a => NFData (RadixTree a) - --- | Radix tree with no elements. -empty :: RadixTree a -empty = RadixNode Nothing IM.empty - -{-# INLINE interleaveST #-} -interleaveST :: ST s a -> ST s a -interleaveST = -#if MIN_VERSION_base(4, 10, 0) - unsafeDupableInterleaveST -#else - unsafeInterleaveST -#endif - -splitShortByteString :: Int -> ShortByteString -> (ShortByteString, ShortByteString, Word8, ShortByteString) -splitShortByteString n (BSSI.SBS source) = runST $ do - prefix <- newByteArray prefixSize - copyByteArray prefix 0 source' 0 prefixSize - ByteArray prefix# <- unsafeFreezeByteArray prefix - midSuffix <- interleaveST $ do - midSuffix <- newByteArray midSuffixSize - copyByteArray midSuffix 0 source' n midSuffixSize - unsafeFreezeByteArray midSuffix - suffix <- interleaveST $ do - suffix <- newByteArray suffixSize - copyByteArray suffix 0 source' (n + 1) suffixSize - unsafeFreezeByteArray suffix - pure (BSSI.SBS prefix#, byteArrayToBSS midSuffix, indexByteArray source' n, byteArrayToBSS suffix) - where - source' = ByteArray source - prefixSize = n - midSuffixSize = sizeofByteArray source' - prefixSize - suffixSize = midSuffixSize - 1 - -{-# INLINE byteArrayToBSS #-} -byteArrayToBSS :: ByteArray -> BSS.ShortByteString -byteArrayToBSS (ByteArray xs) = BSSI.SBS xs - -dropShortByteString :: Int -> ShortByteString -> ShortByteString -dropShortByteString 0 src = src -dropShortByteString !n (BSSI.SBS source) = runST $ do - dest <- newByteArray sz - copyByteArray dest 0 source' n sz - byteArrayToBSS <$> unsafeFreezeByteArray dest - where - source' = ByteArray source - !sz = sizeofByteArray source' - n - -singletonShortByteString :: Word8 -> ShortByteString -singletonShortByteString !c = runST $ do - dest <- newByteArray 1 - writeByteArray dest 0 c - byteArrayToBSS <$> unsafeFreezeByteArray dest - -{-# INLINE unsafeHeadeShortByteString #-} -unsafeHeadeShortByteString :: ShortByteString -> Word8 -unsafeHeadeShortByteString = (`BSSI.unsafeIndex` 0) - -data Mismatch - = IsPrefix - | CommonPrefixThenMismatch - !ShortByteString -- ^ Prefix of node contents common with the key - ShortByteString -- ^ Suffix with the first mismatching byte - Word8 -- ^ First byte of the suffix that caused mismatch - ShortByteString -- ^ Rest of node contents, suffix - deriving (Show, Generic) - -analyseMismatch - :: ShortByteString -- ^ Key - -> Int -- ^ Key offset - -> ShortByteString -- ^ Node contents - -> Mismatch -analyseMismatch (BSSI.SBS key) !keyOffset nodeContentsBS@(BSSI.SBS nodeContents) = - case findMismatch 0 of - Nothing -> IsPrefix - Just mismatchIdx -> - case splitShortByteString mismatchIdx nodeContentsBS of - (prefix, midSuffix, mid, suffix) -> CommonPrefixThenMismatch prefix midSuffix mid suffix - where - keySize = sizeofByteArray key' - keyLeft = keySize - keyOffset - contentsSize = sizeofByteArray nodeContents' - - key' = ByteArray key - nodeContents' = ByteArray nodeContents - - limit :: Int - limit = min keyLeft contentsSize - - findMismatch :: Int -> Maybe Int - findMismatch !i - | i == limit - = if i == contentsSize - then Nothing - else Just i -- Key ended in the middle of node's packed key. - | (indexByteArray key' (keyOffset + i) :: Word8) == indexByteArray nodeContents' i - = findMismatch $ i + 1 - | otherwise - = Just i - -mkRadixNodeFuse :: Maybe a -> IntMap (RadixTree a) -> Maybe (RadixTree a) -mkRadixNodeFuse val children = - case val of - Nothing | IM.null children - -> Nothing - val' | [(c, child)] <- IM.toList children - -> Just $ RadixStr val' (singletonShortByteString $ fromIntegral c) child - _ -> Just $ RadixNode val children - --- Precondition: input string is non-empty -mkRadixStrFuse :: Maybe a -> ShortByteString -> RadixTree a -> Maybe (RadixTree a) -mkRadixStrFuse val str rest = - case (val, rest) of - (val', RadixStr Nothing str' rest') -> - Just $ RadixStr val' (str Semigroup.<> str') rest' - (Nothing, node) - | null node -> Nothing - (val', rest') -> - Just $ RadixStr val' str rest' - -mkRadixStr :: ShortByteString -> RadixTree a -> RadixTree a -mkRadixStr str rest - | BSS.null str = rest - | otherwise = RadixStr Nothing str rest - --- TODO: prove following function correct. - --- | Check whether radix tree is empty -null :: RadixTree a -> Bool -null = \case - RadixNode Nothing children -> IM.null children - RadixStr Nothing _ rest -> null rest - _ -> False - --- | O(n) Get number of elements in a radix tree. -size :: RadixTree a -> Int -size = length - --- | Add new element to a radix tree. -insert :: forall a. ShortByteString -> a -> RadixTree a -> RadixTree a -insert = insertWith const - --- | Add new element to a radix tree. If an element was already present for --- the given key, use supplied funciton @f@ to produce a new value. The --- function will be called like this @f newValue oldValue@. -insertWith :: forall a. (a -> a -> a) -> ShortByteString -> a -> RadixTree a -> RadixTree a -insertWith = insert' - -{-# INLINE insert' #-} -insert' :: forall a. (a -> a -> a) -> ShortByteString -> a -> RadixTree a -> RadixTree a -insert' f key value = go 0 - where - len = BSS.length key - - readKey :: Int -> Int - readKey = fromIntegral . BSSI.unsafeIndex key - - go :: Int -> RadixTree a -> RadixTree a - go i - | i < len - = \case - RadixNode oldValue children - | IM.null children -> - RadixStr oldValue (dropShortByteString i key) $ RadixNode (Just value) IM.empty - | otherwise -> - RadixNode oldValue $ - IM.alter (Just . maybe optNode (go i')) c children - where - c :: Int - c = readKey i - i' = i + 1 - optNode = - mkRadixStr (dropShortByteString i' key) $ RadixNode (Just value) IM.empty - RadixStr oldValue packedKey rest -> - case analyseMismatch key i packedKey of - IsPrefix -> - RadixStr oldValue packedKey $ go (i + BSS.length packedKey) rest - CommonPrefixThenMismatch prefix midSuffix mid suffix -> - (if BSS.null prefix then id else RadixStr oldValue prefix) $ - if isKeyEnded - then - RadixStr (Just value) midSuffix rest - else - RadixNode (if BSS.null prefix then oldValue else Nothing) $ - IM.fromList - [ ( mid' - , mkRadixStr suffix rest - ) - , ( readKey i' - , mkRadixStr (dropShortByteString (i' + 1) key) $ RadixNode (Just value) IM.empty - ) - ] - where - i' = i + BSS.length prefix - isKeyEnded = i' >= len - mid' = fromIntegral mid - | otherwise - = \case - RadixNode oldValue children -> - RadixNode (Just (maybe value (f value) oldValue)) children - RadixStr oldValue key' rest -> - RadixStr (Just (maybe value (f value) oldValue)) key' rest - -canStripPrefixFromShortByteString - :: Int -> ShortByteString -> ShortByteString -> Bool -canStripPrefixFromShortByteString bigStart (BSSI.SBS small) (BSSI.SBS big) - | bigStart + smallSize > bigSize = False - | otherwise = findMismatch 0 - where - small' = ByteArray small - big' = ByteArray big - - smallSize = sizeofByteArray small' - bigSize = sizeofByteArray big' - - findMismatch :: Int -> Bool - findMismatch !i - | i == smallSize - = True - | (indexByteArray small' i :: Word8) == indexByteArray big' (bigStart + i) - = findMismatch $ i + 1 - | otherwise - = False - --- | O(length(key)) Try to find a value associated with the given key. -lookup :: forall a. ShortByteString -> RadixTree a -> Maybe a -lookup key = go 0 - where - len = BSS.length key - - readKey :: Int -> Int - readKey = fromIntegral . BSSI.unsafeIndex key - - go :: Int -> RadixTree a -> Maybe a - go !n tree - | n == len - = case tree of - RadixNode val _ -> val - RadixStr val _ _ -> val - | otherwise - = case tree of - RadixNode _ children -> - IM.lookup (readKey n) children >>= go (n + 1) - RadixStr _ packedKey rest - | canStripPrefixFromShortByteString n packedKey key - -> go (n + BSS.length packedKey) rest - | otherwise - -> Nothing - --- | Construct a radix tree from list of key-value pairs. If some key --- appears twice in the input list, later occurrences will override --- earlier ones. -fromList :: [(ShortByteString, a)] -> RadixTree a -fromList = - L.foldl' (\acc (k, v) -> insert' const k v acc) empty - --- | O(n) Convert a radix tree to a list of key-value pairs. -toList :: RadixTree a -> [(ShortByteString, a)] -toList = toAscList - --- | O(n) Convert a radix tree to an ascending list of key-value pairs. -toAscList :: forall a. RadixTree a -> [(ShortByteString, a)] -toAscList = map (first BSS.pack) . go - where - go :: RadixTree a -> [([Word8], a)] - go = \case - RadixNode val children -> - maybe id (\val' ys -> ([], val') : ys) val $ - IM.foldMapWithKey (\c child -> map (first (fromIntegral c :)) $ go child) children - RadixStr val packedKey rest -> - maybe id (\val' ys -> ([], val') : ys) val $ - map (first (BSS.unpack packedKey ++)) $ - go rest - --- | O(n) Get all keys stored in a radix tree. -keys :: RadixTree a -> [ShortByteString] -keys = map BSS.pack . go - where - go :: RadixTree a -> [[Word8]] - go = \case - RadixNode val children -> - maybe id (\_ ys -> [] : ys) val $ - IM.foldMapWithKey (\c child -> map (fromIntegral c :) $ go child) children - RadixStr val packedKey rest -> - maybe id (\_ ys -> [] : ys) val $ - map (BSS.unpack packedKey <>) $ - go rest - --- | O(n) Get set of all keys stored in a radix tree. -keysSet :: RadixTree a -> Set ShortByteString -keysSet = S.fromDistinctAscList . keys - --- | O(n) Get all values stored in a radix tree. -elems :: RadixTree a -> [a] -elems = Foldable.toList - --- | O(n) Map a function that can remove some existing elements over a --- radix tree. -mapMaybe :: forall a b. (a -> Maybe b) -> RadixTree a -> RadixTree b -mapMaybe f = fromMaybe empty . go - where - go :: RadixTree a -> Maybe (RadixTree b) - go = \case - RadixNode val children -> - mkRadixNodeFuse (f =<< val) $ IM.mapMaybe go children - RadixStr val str rest -> - mkRadixStrFuse (f =<< val) str $ fromMaybe empty $ go rest - --- | O(n + m) Combine two radix trees trees. If a key is present in both --- trees then the value from left one will be retained. -union :: RadixTree a -> RadixTree a -> RadixTree a -union = unionWith const - --- | O(n + m) Combine two trees using supplied function to resolve --- values that have the same key in both trees. -unionWith :: forall a. (a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a -unionWith f = go - where - combineVals :: Maybe a -> Maybe a -> Maybe a - combineVals x y = case (x, y) of - (Nothing, Nothing) -> Nothing - (Nothing, y'@Just{}) -> y' - (x'@Just{}, Nothing) -> x' - (Just x', Just y') -> Just $ f x' y' - - go :: RadixTree a -> RadixTree a -> RadixTree a - go x y = case (x, y) of - (RadixNode val children, RadixNode val' children') -> - RadixNode (combineVals val val') (IM.unionWith go children children') - (RadixNode val children, RadixStr val' str' rest') -> - RadixNode (combineVals val val') $ - (\g -> IM.alter g h children) $ \child -> - Just $! - let rest'' = mkRadixStr (dropShortByteString 1 str') rest' in - case child of - Nothing -> rest'' - Just child' -> go child' rest'' - where - h = fromIntegral $ unsafeHeadeShortByteString str' - (RadixStr val str rest, RadixNode val' children') -> - RadixNode (combineVals val val') $ - (\g -> IM.alter g h children') $ \child -> - Just $! - let rest' = mkRadixStr (dropShortByteString 1 str) rest in - case child of - Nothing -> rest' - Just child' -> go rest' child' - where - h = fromIntegral $ unsafeHeadeShortByteString str - (RadixStr val str rest, RadixStr val' str' rest') -> - case analyseMismatch str 0 str' of - -- str' is a prefix of str - IsPrefix -> - RadixStr (combineVals val val') str' $ - go (mkRadixStr (dropShortByteString (BSS.length str') str) rest) rest' - -- str' = prefix + firstMismatchStr' + suffixStr' - -- = prefix + midSuffixStr' - CommonPrefixThenMismatch prefix midSuffixStr' firstMismatchStr' suffixStr' -> - (if BSS.null prefix then id else RadixStr (combineVals val val') prefix) $ - if BSS.length prefix == BSS.length str - then - go rest $ RadixStr - (if BSS.null prefix then combineVals val val' else Nothing) - midSuffixStr' - rest' - else RadixNode (if BSS.null prefix then combineVals val val' else Nothing) $ IM.fromList - [ ( fromIntegral firstMismatchStr' - , mkRadixStr suffixStr' rest' - ) - , ( fromIntegral $ BSSI.unsafeIndex str $ BSS.length prefix - , mkRadixStr (dropShortByteString (BSSI.length prefix + 1) str) rest - ) - ] diff --git a/src/Data/RadixTree/Word8/Key.hs b/src/Data/RadixTree/Word8/Key.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Key.hs @@ -0,0 +1,90 @@ +{-| + Safe functions for building and destroying radix tree keys. + -} + +module Data.RadixTree.Word8.Key + ( -- * Build + Build + + -- ** Raw + , buildBytes + + -- ** ByteString + , buildByteString + , buildShortByteString + + -- ** Text + -- | See "Data.RadixTree.Word8.Key.Unsafe#g:build/text". + + -- * Feed + , Feed + + -- ** Raw + , feedBytes + + -- ** ByteString + , feedByteString + , feedShortByteString + , feedLazyByteString + + -- ** Text + , feedText + , feedLazyText + ) where + +import Data.RadixNTree.Word8.Key + +import qualified Data.ByteString as Strict (ByteString) +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import Data.ByteString.Short (ShortByteString) +import qualified Data.Text as Strict (Text) +import qualified Data.Text.Lazy as Lazy (Text) +import Data.Word + + + +-- | Convert a key into a list of bytes. +buildBytes :: Build -> [Word8] +buildBytes = buildBytes0 + +-- | Convert a key into a strict 'Strict.ByteString'. +buildByteString :: Build -> Strict.ByteString +buildByteString = buildByteString0 + +-- | Convert a key into a 'ShortByteString'. +buildShortByteString :: Build -> ShortByteString +buildShortByteString = buildShortByteString0 + + + +{-# INLINE feedBytes #-} +-- | Convert a list of bytes into a key. +feedBytes :: [Word8] -> Feed +feedBytes = feedBytes0 + +{-# INLINE feedByteString #-} +-- | Convert a strict 'Strict.ByteString' into a key. +feedByteString :: Strict.ByteString -> Feed +feedByteString = feedByteString0 + +{-# INLINE feedShortByteString #-} +-- | Convert a 'ShortByteString' into a key. +feedShortByteString :: ShortByteString -> Feed +feedShortByteString = feedShortByteString0 + +{-# INLINE feedLazyByteString #-} +-- | Convert a lazy 'Lazy.ByteString' into a key. +feedLazyByteString :: Lazy.ByteString -> Feed +feedLazyByteString = feedLazyByteString0 + + + +{-# INLINE feedText #-} +-- | Convert a strict 'Strict.Text' into a key. +feedText :: Strict.Text -> Feed +feedText = feedText0 + +{-# INLINE feedLazyText #-} +-- | Convert a lazy 'Lazy.Text' into a key. +feedLazyText :: Lazy.Text -> Feed +feedLazyText = feedLazyText0 diff --git a/src/Data/RadixTree/Word8/Key/Unsafe.hs b/src/Data/RadixTree/Word8/Key/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Key/Unsafe.hs @@ -0,0 +1,32 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| + Radix tree key internals, and unsafe functions for building and destroying them. + -} + +module Data.RadixTree.Word8.Key.Unsafe + ( -- * Build + Build (..) + , Tsil (..) + + -- ** Text #build/text# + , unsafeBuildText + + -- * Feed + , Feed (..) + , Step (..) + ) where + +import Data.ByteArray.NonEmpty (Step (..)) +import Data.RadixNTree.Word8.Key + +import qualified Data.Text as Strict (Text) + + + +-- | Convert a key into a strict 'Strict.Text'. +-- +-- No checks are made to ensure the resulting value is a valid sequence +-- of UTF-8 code units. +unsafeBuildText :: Build -> Strict.Text +unsafeBuildText = unsafeBuildText0 diff --git a/src/Data/RadixTree/Word8/Lazy.hs b/src/Data/RadixTree/Word8/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Lazy.hs @@ -0,0 +1,789 @@ +{-| + @'LazyRadixTree' a@ is a spine-lazy radix tree that uses byte-aligned + byte sequences as keys. + + == Laziness + + Evaluating any particular entry in the tree to WHNF forces the evaluation + of the part of the spine leading up to that entry to normal form. + + == Performance + + Each function's time complexity is provided in the documentation. + + Laziness-amortized functions specify two time complexities: + time to construct the return value (denoted with a \(\texttt{+}\)) and time to + fully apply the function to the tree. + + \(x\) is the length of the input key. + + \(k\) is the length of the longest key stored in the tree. + + \(n\) refers to the total number of entries in the tree. + Parts of the tree are denoted using subscripts: \(n_L\) refers to the left side, + \(n_R\) to the right side, and \(n_M\) to entries collected with the use of a 'Monoid'. + + == Inlining + + Functions that produce and consume 'Feed's are treated specially within the library, + as when combined they can be reduced in a manner similar to the + [destroy/unfoldr elimination rule](https://wiki.haskell.org/Correctness_of_short_cut_fusion#destroy.2Funfoldr). + + The elimination in this library is achieved by inlining both types of functions + heavily. To avoid unnecessary code duplication during compilation consider creating + helper functions that apply these functions one to another, e.g. + + @updateBS f bs = 'update' f ('Data.RadixTree.Word8.Key.feedByteString' bs)@ + + N.B. To inline properly functions that consume 'Feed's must mention all of the + arguments except for the tree. + + == Implementation + + See the implementation section in "Data.RadixTree.Word8.Strict.Unsafe" + for the explanation of the innerworkings. + + See the implementation section in "Data.Patricia.Word.Strict" for literary references. + -} + +module Data.RadixTree.Word8.Lazy + ( LazyRadixTree + , RadixTree (..) + + -- * Key + , module Data.RadixTree.Word8.Key + + -- * Construct + , empty + , singleton + + -- ** Convert + , toStrict + + -- * Single-key + -- ** Lookup + , Data.RadixTree.Word8.Lazy.lookup + , Data.RadixTree.Word8.Lazy.find + , Data.RadixTree.Word8.Lazy.member + , subtree + + -- *** Chunked + -- + -- | Chunked lookup allows providing the key piece by piece while retaining + -- the ability to check for early failure. + -- + -- Note that while 'subtree' can be used to achieve the same result, + -- it is more expensive allocation-wise, as it must ensure that + -- the resulting tree is well-formed after each chunk application. + , Cursor + , cursor + , move + , stop + , Location (..) + , locate + + -- ** Insert + , insert + , insertWith + + -- ** Map + , adjust + + -- ** Delete + , delete + , prune + + -- ** Update + , update + , alter + , shape + + -- ** Take + , splitLookup + + -- * Directional + , Openness (..) + + -- ** Lookup + , Lookup (..) + , lookupL + , lookupR + + -- ** Map + -- | === Left + , adjustL + , adjustLWithKey + + -- | === Right + , adjustR + , adjustRWithKey + + -- ** Update + -- | === Left + , updateL + , updateLWithKey + + -- | === Right + , updateR + , updateRWithKey + + -- ** Take + -- | === Left + , takeL + , splitL + + -- | === Right + , takeR + + -- * Edges + + -- ** Lookup + -- | === Min + , lookupMin + , lookupMinWithKey + + -- | === Max + , lookupMax + , lookupMaxWithKey + + -- ** Map + -- | === Min + , adjustMin + , adjustMinWithKey + + -- | === Max + , adjustMax + , adjustMaxWithKey + + -- ** Delete + , deleteMin + , deleteMax + + -- ** Update + -- | === Min + , updateMin + , updateMinWithKey + + -- | === Max + , updateMax + , updateMaxWithKey + + -- ** View + -- | === Min + , ViewL (..) + , minView + + -- | === Max + , ViewR (..) + , maxView + + -- * Full tree + -- ** Size + , Data.RadixTree.Word8.Lazy.null + , size + + -- ** Extend + , prefix + + -- ** Map + , Data.RadixTree.Word8.Lazy.map + , mapWithKey + + -- ** Fold + -- | === Left-to-right + , Data.RadixTree.Word8.Lazy.foldl + , Data.RadixTree.Word8.Lazy.foldl' + , foldlWithKey + , foldlWithKey' + + -- | === Right-to-left + , Data.RadixTree.Word8.Lazy.foldr + , Data.RadixTree.Word8.Lazy.foldr' + , foldrWithKey + , foldrWithKey' + + -- | === Monoid + , Data.RadixTree.Word8.Lazy.foldMap + , foldMapWithKey + + -- ** Traverse + , Data.RadixTree.Word8.Lazy.traverse + , traverseWithKey + + -- ** Filter + -- | === One side + , Data.RadixTree.Word8.Lazy.filter + , filterWithKey + + , mapMaybe + , mapMaybeWithKey + + -- | === Both sides + , partition + , partitionWithKey + + , mapEither + , mapEitherWithKey + + -- ** Comparison + , PartialOrdering (..) + , Data.RadixTree.Word8.Lazy.compare + + -- ** Union + , union + , unionL + , unionWith + , unionWithKey + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , disjoint + , intersection + , intersectionL + , intersectionWith + , intersectionWithKey + + -- ** Merge + -- | See 'Data.RadixTree.Word8.Lazy.Unsafe.merge'. + ) where + +import Data.RadixTree.Word8.Key +import Data.RadixNTree.Word8.Common +import Data.RadixNTree.Word8.Conversion +import Data.RadixNTree.Word8.Lazy +import Radix.Common + + + +-- | \(\mathcal{O}(1)\). +-- Empty tree. +empty :: RadixTree a +empty = empty0 + +{-# INLINE singleton #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(x)\). +-- Tree with a single entry. +singleton :: Feed -> a -> RadixTree a +singleton = singleton0 + + +-- | \(\mathcal{O}(n)\). +-- Create a strict 'Strict.Patricia' tree from a lazy one. +-- +-- The resulting tree does not share its data representation with the original. +toStrict :: LazyRadixTree a -> StrictRadixTree a +toStrict = toStrict0 + + + +-- | \(\mathcal{O}(1)\). +-- Check if the tree is empty. +null :: RadixTree a -> Bool +null = null0 + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of elements stored in the tree. +-- The returned number is guaranteed to be non-negative. +size :: RadixTree a -> Int +size = size0 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree. +map :: (a -> b) -> RadixTree a -> RadixTree b +map = map0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree. +mapWithKey :: (Build -> a -> b) -> RadixTree a -> RadixTree b +mapWithKey = mapWithKey0 + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldl :: (b -> a -> b) -> b -> RadixTree a -> b +foldl = Data.RadixNTree.Word8.Lazy.foldl0 + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldlWithKey :: (b -> Build -> a -> b) -> b -> RadixTree a -> b +foldlWithKey = foldlWithKey0 + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldl' :: (b -> a -> b) -> b -> RadixTree a -> b +foldl' = foldl0' + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldlWithKey' :: (b -> Build -> a -> b) -> b -> RadixTree a -> b +foldlWithKey' = foldlWithKey0' + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldr :: (a -> b -> b) -> b -> RadixTree a -> b +foldr = Data.RadixNTree.Word8.Lazy.foldr0 + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldrWithKey :: (Build -> a -> b -> b) -> b -> RadixTree a -> b +foldrWithKey = foldrWithKey0 + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldr' :: (a -> b -> b) -> b -> RadixTree a -> b +foldr' = foldr0' + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldrWithKey' :: (Build -> a -> b -> b) -> b -> RadixTree a -> b +foldrWithKey' = foldrWithKey0' + + + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMap :: Monoid m => (a -> m) -> RadixTree a -> m +foldMap = foldMap0 + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMapWithKey :: Monoid m => (Build -> a -> m) -> RadixTree a -> m +foldMapWithKey = foldMapWithKey0 + + + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverse :: Applicative f => (a -> f b) -> RadixTree a -> f (RadixTree b) +traverse = traverse0 + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverseWithKey + :: Applicative f => (Build -> a -> f b) -> RadixTree a -> f (RadixTree b) +traverseWithKey = traverseWithKey0 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filter :: (a -> Bool) -> RadixTree a -> RadixTree a +filter = filter0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filterWithKey :: (Build -> a -> Bool) -> RadixTree a -> RadixTree a +filterWithKey = filterWithKey0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +mapMaybe :: (a -> Maybe b) -> RadixTree a -> RadixTree b +mapMaybe = mapMaybe0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +mapMaybeWithKey :: (Build -> a -> Maybe b) -> RadixTree a -> RadixTree b +mapMaybeWithKey = mapMaybeWithKey0 + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partition :: (a -> Bool) -> RadixTree a -> (RadixTree a, RadixTree a) +partition = partition0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partitionWithKey :: (Build -> a -> Bool) -> RadixTree a -> (RadixTree a, RadixTree a) +partitionWithKey = partitionWithKey0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +mapEither :: (a -> Either b c) -> RadixTree a -> (RadixTree b, RadixTree c) +mapEither = mapEither0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +mapEitherWithKey :: (Build -> a -> Either b c) -> RadixTree a -> (RadixTree b, RadixTree c) +mapEitherWithKey = mapEitherWithKey0 + + + +{-# INLINE lookup #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the value at a key in the tree. +lookup :: Feed -> RadixTree a -> Maybe a +lookup = lookup0 + +{-# INLINE find #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the value at a key in the tree, falling back to the given default value +-- if it does not exist. +find :: a -> Feed -> RadixTree a -> a +find = find0 + +{-# INLINE member #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Check whether the value exists at a key in the tree. +member :: Feed -> RadixTree a -> Bool +member = member0 + +{-# INLINE subtree #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the part of the tree below the given prefix. +subtree :: Feed -> RadixTree a -> RadixTree a +subtree = subtree0 + +{-# INLINE prefix #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(x)\). +-- Prefix the root of the tree with the given key. +prefix :: Feed -> RadixTree a -> RadixTree a +prefix = prefix0 + + +-- | \(\mathcal{O}(1)\). +-- Make a cursor that points to the root of the tree. +cursor :: RadixTree a -> Cursor a +cursor = cursor0 + +{-# INLINE move #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Move the cursor down by the extent of the given key. +move :: Feed -> Cursor a -> Cursor a +move = move0 + + + +{-# INLINE insert #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, it is replaced. +insert :: Feed -> a -> RadixTree a -> RadixTree a +insert = insert0 + +{-# INLINE insertWith #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, the function is used instead. +insertWith :: (a -> a) -> Feed -> a -> RadixTree a -> RadixTree a +insertWith = insertWith0 + + +{-# INLINE adjust #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Apply a function to a value in the tree at the given key. +adjust :: (a -> a) -> Feed -> RadixTree a -> RadixTree a +adjust = adjust0 + + +{-# INLINE delete #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Delete a value in the tree at the given key. +delete :: Feed -> RadixTree a -> RadixTree a +delete = delete0 + +{-# INLINE prune #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Delete values in the tree below the given key. +prune :: Openness -> Feed -> RadixTree a -> RadixTree a +prune = prune0 + + +{-# INLINE update #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Update or delete a value in the tree at the given key. +update :: (a -> Maybe a) -> Feed -> RadixTree a -> RadixTree a +update = update0 + + +{-# INLINE alter #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Insert, update or delete a value in the tree at the given key. +alter :: (Maybe a -> Maybe a) -> Feed -> RadixTree a -> RadixTree a +alter = alter0 + + +{-# INLINE shape #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Update the part of the tree at the given prefix. +shape :: (RadixTree a -> RadixTree a) -> Feed -> RadixTree a -> RadixTree a +shape = shape0 + + +{-# INLINE splitLookup #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Split the tree into two, such that +-- values with keys smaller than the given one are on the left, +-- values with keys greater than the given one are on the right, +-- and the value at the given key is returned separately. +splitLookup :: Feed -> RadixTree a -> (RadixTree a, Maybe a, RadixTree a) +splitLookup = splitLookup0 + + + +{-# INLINE lookupL #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up a value at a largest key smaller than (or equal to) the given key. +lookupL :: Openness -> Feed -> RadixTree a -> Maybe (Lookup a) +lookupL = lookupL0 + + +{-# INLINE lookupR #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up a value at a smallest key greater than (or equal to) the given key. +lookupR :: Openness -> Feed -> RadixTree a -> Maybe (Lookup a) +lookupR = lookupR0 + + + +{-# INLINE adjustL #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +adjustL :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustL = adjustL0 + +{-# INLINE adjustLWithKey #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +adjustLWithKey :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustLWithKey = adjustLWithKey0 + + + +{-# INLINE adjustR #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +adjustR :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustR = adjustR0 + +{-# INLINE adjustRWithKey #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +adjustRWithKey :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustRWithKey = adjustRWithKey0 + + + +{-# INLINE updateL #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_L)\). +-- Update every value for which the key is smaller than (or equal to) the given one. +updateL :: (a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateL = updateL0 + +{-# INLINE updateLWithKey #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_L)\). +-- Update every value for which the key is smaller than (or equal to) the given one. +updateLWithKey :: (Build -> a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateLWithKey = updateLWithKey0 + +{-# INLINE updateR #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_R)\). +-- Update every value for which the key is greater than (or equal to) the given one. +updateR :: (a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateR = updateR0 + +{-# INLINE updateRWithKey #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k) + n_R)\). +-- Update every value for which the key is greater than (or equal to) the given one. +updateRWithKey :: (Build -> a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateRWithKey = updateRWithKey0 + + + +{-# INLINE takeL #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Take values for which keys are smaller than (or equal to) the given one. +takeL :: Openness -> Feed -> RadixTree a -> RadixTree a +takeL = takeL0 + +{-# INLINE takeR #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Take values for which keys are greater than (or equal to) the given one. +takeR :: Openness -> Feed -> RadixTree a -> RadixTree a +takeR = takeR0 + + + +{-# INLINE splitL #-} +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(\min(x,k))\). +-- Split the tree into two, such that +-- values with keys smaller than (or equal to) the given one are on the left, +-- and the rest are on the right. +splitL :: Openness -> Feed -> RadixTree a -> (RadixTree a, RadixTree a) +splitL = splitL0 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +lookupMin :: RadixTree a -> Maybe a +lookupMin = lookupMin0 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +lookupMinWithKey :: RadixTree a -> Maybe (Lookup a) +lookupMinWithKey = lookupMinWithKey0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Delete a value at the leftmost key in the tree. +deleteMin :: RadixTree a -> RadixTree a +deleteMin = deleteMin0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +adjustMin :: (a -> a) -> RadixTree a -> RadixTree a +adjustMin = adjustMin0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +adjustMinWithKey :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMinWithKey = adjustMinWithKey0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +updateMin :: (a -> Maybe a) -> RadixTree a -> RadixTree a +updateMin = updateMin0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +updateMinWithKey :: (Build -> a -> Maybe a) -> RadixTree a -> RadixTree a +updateMinWithKey = updateMinWithKey0 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the leftmost value and return it alongside the tree without it. +minView :: RadixTree a -> Maybe (ViewL a) +minView = minView0 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +lookupMax :: RadixTree a -> Maybe a +lookupMax = lookupMax0 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +lookupMaxWithKey :: RadixTree a -> Maybe (Lookup a) +lookupMaxWithKey = lookupMaxWithKey0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Delete a value at the rightmost key in the tree. +deleteMax :: RadixTree a -> RadixTree a +deleteMax = deleteMax0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +adjustMax :: (a -> a) -> RadixTree a -> RadixTree a +adjustMax = adjustMax0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +adjustMaxWithKey :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMaxWithKey = adjustMaxWithKey0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +updateMax :: (a -> Maybe a) -> RadixTree a -> RadixTree a +updateMax = updateMax0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +updateMaxWithKey :: (Build -> a -> Maybe a) -> RadixTree a -> RadixTree a +updateMaxWithKey = updateMaxWithKey0 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the rightmost value and return it alongside the tree without it. +maxView :: RadixTree a -> Maybe (ViewR a) +maxView = maxView0 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Unbiased union of two trees. +union :: RadixTree a -> RadixTree a -> RadixTree a +union = union0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Left-biased union of two trees. +unionL :: RadixTree a -> RadixTree a -> RadixTree a +unionL = unionL0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Union of two trees with a combining function. +unionWith :: (a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a +unionWith = unionWith0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Union of two trees with a combining function. +unionWithKey :: (Build -> a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a +unionWithKey = unionWithKey0 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees. +difference :: RadixTree a -> RadixTree b -> RadixTree a +difference = difference0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees with a combining function. +differenceWith :: (a -> b -> Maybe a) -> RadixTree a -> RadixTree b -> RadixTree a +differenceWith = differenceWith0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees with a combining function. +differenceWithKey + :: (Build -> a -> b -> Maybe a) -> RadixTree a -> RadixTree b -> RadixTree a +differenceWithKey = differenceWithKey0 + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Compare two trees with respect to set inclusion, +-- using the given equality function for intersecting keys. +-- If any intersecting keys hold unequal values, the trees are 'Incomparable'. +compare :: (a -> b -> Bool) -> RadixTree a -> RadixTree b -> PartialOrdering +compare = compare0 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Determine whether two trees' key sets are disjoint. +disjoint :: RadixTree a -> RadixTree b -> Bool +disjoint = disjoint0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Unbiased intersection of two trees. +intersection :: RadixTree a -> RadixTree a -> RadixTree a +intersection = intersection0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Left-biased intersection of two trees. +intersectionL :: RadixTree a -> RadixTree b -> RadixTree a +intersectionL = intersectionL0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Intersection of two trees with a combining function. +intersectionWith :: (a -> b -> c) -> RadixTree a -> RadixTree b -> RadixTree c +intersectionWith = intersectionWith0 + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- Intersection of two trees with a combining function. +intersectionWithKey :: (Build -> a -> b -> c) -> RadixTree a -> RadixTree b -> RadixTree c +intersectionWithKey = intersectionWithKey0 diff --git a/src/Data/RadixTree/Word8/Lazy/Debug.hs b/src/Data/RadixTree/Word8/Lazy/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Lazy/Debug.hs @@ -0,0 +1,30 @@ +{-| + Safe functions for datatype introspection. + -} + +module Data.RadixTree.Word8.Lazy.Debug + ( -- * Show + showsTree + + -- * Validate + , Validity (..) + , Reason (..) + , validate + ) where + +import Data.RadixNTree.Word8.Lazy (RadixTree) +import Data.RadixNTree.Word8.Lazy.Debug + + + +-- | \(\mathcal{O}(n)\). +-- Shows the internal structure of the tree. +showsTree :: (a -> ShowS) -> RadixTree a -> ShowS +showsTree = showsTree0 + + + +-- | \(\mathcal{O}(n)\). +-- Checks whether the tree is well-formed. +validate :: RadixTree a -> Validity +validate = validate0 diff --git a/src/Data/RadixTree/Word8/Lazy/TH.hs b/src/Data/RadixTree/Word8/Lazy/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Lazy/TH.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{-| + Template Haskell helper functions. + -} + +module Data.RadixTree.Word8.Lazy.TH + ( sequenceCode + ) where + +import Data.RadixNTree.Word8.Lazy.TH + +import Language.Haskell.TH.Syntax + + + +-- | \(\mathcal{O}(n)\). +-- Evaluate a tree of typed expressions. +sequenceCode :: Quote m => RadixTree (Code m a) -> Code m (RadixTree a) +sequenceCode = sequenceCode0 diff --git a/src/Data/RadixTree/Word8/Lazy/Unsafe.hs b/src/Data/RadixTree/Word8/Lazy/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Lazy/Unsafe.hs @@ -0,0 +1,57 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| + Data structure internals, helper operations and unsafe functions. + -} + +module Data.RadixTree.Word8.Lazy.Unsafe + ( RadixTree (..) + , Radix1Tree (..) + + -- * Bit operations + , Prefix + , Key + + -- | === Compare + , beyond + , upper + , lower + + -- | === Create + , Mask + , zeroBit + , mask + , branchingBit + + -- * Exceptions + , MalformedTree (..) + + -- * Full-tree + -- ** Merge + , merge + ) where + +import Data.RadixNTree.Word8.Key +import Data.RadixNTree.Word8.Lazy +import Radix.Exception +import Radix.Word8.Foundation + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n_A k_A + n_B k_B)\). +-- General merge of two trees. +-- +-- Resulting 'Maybe's and 'Radix1Tree's in argument functions are evaluated to WHNF. +-- +-- This functions inlines when all argument functions are provided. +{-# INLINE merge #-} +merge + :: (Build -> a -> b -> Maybe c) -- ^ Single value collision + -> (Build -> a -> Maybe c) -- ^ Single left value + -> (Build -> Radix1Tree a -> Radix1Tree c) -- ^ Left subtree + -> (Build -> b -> Maybe c) -- ^ Single right value + -> (Build -> Radix1Tree b -> Radix1Tree c) -- ^ Right subtree + -> RadixTree a + -> RadixTree b + -> RadixTree c +merge = merge0 diff --git a/src/Data/RadixTree/Word8/Strict.hs b/src/Data/RadixTree/Word8/Strict.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Strict.hs @@ -0,0 +1,926 @@ +{-| + @'StrictRadixTree' a@ is a spine-strict radix tree that uses byte-aligned + byte sequences as keys. + + == Laziness + + Evaluating the root of the tree (i.e. @(_ :: 'StrictRadixTree' a)@) to + weak head normal form evaluates the entire spine of the tree to normal form. + + Functions do not perform any additional evaluations unless + their documentation directly specifies so. + + == Performance + + Each function's time complexity is provided in the documentation. + + \(x\) is the length of the input key. + + \(k\) is the length of the longest key stored in the tree. + + \(n\) refers to the total number of entries in the tree. + Parts of the tree are denoted using subscripts: \(n_L\) refers to the left side, + \(n_R\) to the right side, and \(n_M\) to entries collected with the use of a 'Monoid'. + + == Inlining + + Functions that produce and consume 'Feed's are treated specially within the library, + as when combined they can be reduced in a manner similar to the + [destroy/unfoldr elimination rule](https://wiki.haskell.org/Correctness_of_short_cut_fusion#destroy.2Funfoldr). + + The elimination in this library is achieved by inlining both types of functions + heavily. To avoid unnecessary code duplication during compilation consider creating + helper functions that apply these functions one to another, e.g. + + @updateBS f bs = 'update' f ('Data.RadixTree.Word8.Key.feedByteString' bs)@ + + N.B. To inline properly functions that consume 'Feed's must mention all of the + arguments except for the tree. + + == Implementation + + See the implementation section in "Data.RadixTree.Word8.Strict.Unsafe" + for the explanation of the innerworkings. + + See the implementation section in "Data.Patricia.Word.Strict" for literary references. + -} + +module Data.RadixTree.Word8.Strict + ( StrictRadixTree + , RadixTree (..) + + -- * Key + , module Data.RadixTree.Word8.Key + + -- * Construct + , empty + , singleton + + -- ** Convert + , toLazy + + -- * Single-key + -- ** Lookup + , Data.RadixTree.Word8.Strict.lookup + , Data.RadixTree.Word8.Strict.find + , Data.RadixTree.Word8.Strict.member + , subtree + + -- *** Chunked + -- + -- | Chunked lookup allows providing the key piece by piece while retaining + -- the ability to check for early failure. + -- + -- Note that while 'subtree' can be used to achieve the same result, + -- it is more expensive allocation-wise, as it must ensure that + -- the resulting tree is well-formed after each chunk application. + , Cursor + , cursor + , move + , stop + , Location (..) + , locate + + -- ** Insert + , insert + , insertWith + , insertWith' + + -- ** Map + , adjust + , adjust' + + -- ** Delete + , delete + , prune + + -- ** Update + , update + , alter + , shape + + -- ** Take + , SplitLookup (..) + , splitLookup + + -- * Directional + , Openness (..) + + -- ** Lookup + , Lookup (..) + , lookupL + , lookupR + + -- ** Map + -- | === Left + , adjustL + , adjustL' + , adjustLWithKey + , adjustLWithKey' + + -- | === Right + , adjustR + , adjustR' + , adjustRWithKey + , adjustRWithKey' + + -- ** Update + -- | === Left + , updateL + , updateLWithKey + + -- | === Right + , updateR + , updateRWithKey + + -- ** Take + , Split (..) + + -- | === Left + , takeL + , splitL + + -- | === Right + , takeR + + -- * Edges + + -- ** Lookup + -- | === Min + , lookupMin + , lookupMinWithKey + + -- | === Max + , lookupMax + , lookupMaxWithKey + + -- ** Map + -- | === Min + , adjustMin + , adjustMin' + , adjustMinWithKey + , adjustMinWithKey' + + -- | === Max + , adjustMax + , adjustMax' + , adjustMaxWithKey + , adjustMaxWithKey' + + -- ** Delete + , deleteMin + , deleteMax + + -- ** Update + -- | === Min + , updateMin + , updateMinWithKey + + -- | === Max + , updateMax + , updateMaxWithKey + + -- ** View + -- | === Min + , ViewL (..) + , minView + + -- | === Max + , ViewR (..) + , maxView + + -- * Full tree + -- ** Size + , Data.RadixTree.Word8.Strict.null + , size + + -- ** Extend + , prefix + + -- ** Map + , Data.RadixTree.Word8.Strict.map + , map' + , mapWithKey + , mapWithKey' + + -- ** Fold + -- | === Left-to-right + , Data.RadixTree.Word8.Strict.foldl + , Data.RadixTree.Word8.Strict.foldl' + , foldlWithKey + , foldlWithKey' + + -- | === Right-to-left + , Data.RadixTree.Word8.Strict.foldr + , Data.RadixTree.Word8.Strict.foldr' + , foldrWithKey + , foldrWithKey' + + -- | === Monoid + , Data.RadixTree.Word8.Strict.foldMap + , foldMapWithKey + + -- ** Traverse + , Data.RadixTree.Word8.Strict.traverse + , traverseWithKey + + -- ** Filter + -- | === One side + , Data.RadixTree.Word8.Strict.filter + , filterWithKey + + , mapMaybe + , mapMaybeWithKey + + -- | === Both sides + , partition + , partitionWithKey + + , mapEither + , mapEitherWithKey + + -- ** Comparison + , PartialOrdering (..) + , Data.RadixTree.Word8.Strict.compare + + -- ** Union + , union + , unionL + , unionWith' + , unionWithKey' + + -- ** Difference + , difference + , differenceWith + , differenceWithKey + + -- ** Intersection + , disjoint + , intersection + , intersectionL + , intersectionWith' + , intersectionWithKey' + + -- ** Merge + -- | See 'Data.RadixTree.Word8.Strict.Unsafe.merge'. + ) where + +import Data.RadixTree.Word8.Key +import Data.RadixNTree.Word8.Common +import Data.RadixNTree.Word8.Conversion +import Data.RadixNTree.Word8.Strict +import Radix.Common + + + +-- | \(\mathcal{O}(1)\). +-- Empty tree. +empty :: RadixTree a +empty = empty0 + +{-# INLINE singleton #-} +-- | \(\mathcal{O}(x)\). +-- Tree with a single entry. +singleton :: Feed -> a -> RadixTree a +singleton = singleton0 + + + +-- | \(\mathcal{O}(1)\texttt{+}, \mathcal{O}(n)\). +-- Create a lazy 'Lazy.Patricia' tree from a strict one. +-- +-- The resulting tree does not share its data representation with the original. +toLazy :: StrictRadixTree a -> LazyRadixTree a +toLazy = toLazy0 + + + +-- | \(\mathcal{O}(1)\). +-- Check if the tree is empty. +null :: RadixTree a -> Bool +null = null0 + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of elements stored in the tree. +-- The returned number is guaranteed to be non-negative. +size :: RadixTree a -> Int +size = size0 + + + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +map :: (a -> b) -> RadixTree a -> RadixTree b +map = map0 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +map' :: (a -> b) -> RadixTree a -> RadixTree b +map' = map0' + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +mapWithKey :: (Build -> a -> b) -> RadixTree a -> RadixTree b +mapWithKey = mapWithKey0 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree. +mapWithKey' :: (Build -> a -> b) -> RadixTree a -> RadixTree b +mapWithKey' = mapWithKey0' + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldl :: (b -> a -> b) -> b -> RadixTree a -> b +foldl = Data.RadixNTree.Word8.Strict.foldl0 + +-- | \(\mathcal{O}(n_R)\). +-- Fold the tree left-to-right. +foldlWithKey :: (b -> Build -> a -> b) -> b -> RadixTree a -> b +foldlWithKey = foldlWithKey0 + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldl' :: (b -> a -> b) -> b -> RadixTree a -> b +foldl' = foldl0' + +-- | \(\mathcal{O}(n)\). +-- Fold the tree left-to-right with a strict accumulator. +foldlWithKey' :: (b -> Build -> a -> b) -> b -> RadixTree a -> b +foldlWithKey' = foldlWithKey0' + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldr :: (a -> b -> b) -> b -> RadixTree a -> b +foldr = Data.RadixNTree.Word8.Strict.foldr0 + +-- | \(\mathcal{O}(n_L)\). +-- Fold the tree right-to-left. +foldrWithKey :: (Build -> a -> b -> b) -> b -> RadixTree a -> b +foldrWithKey = foldrWithKey0 + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldr' :: (a -> b -> b) -> b -> RadixTree a -> b +foldr' = foldr0' + +-- | \(\mathcal{O}(n)\). +-- Fold the tree right-to-left with a strict accumulator. +foldrWithKey' :: (Build -> a -> b -> b) -> b -> RadixTree a -> b +foldrWithKey' = foldrWithKey0' + + + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMap :: Monoid m => (a -> m) -> RadixTree a -> m +foldMap = foldMap0 + +-- | \(\mathcal{O}(n_M)\). +-- Map each element in the tree to a monoid and combine the results. +foldMapWithKey :: Monoid m => (Build -> a -> m) -> RadixTree a -> m +foldMapWithKey = foldMapWithKey0 + + + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverse :: Applicative f => (a -> f b) -> RadixTree a -> f (RadixTree b) +traverse = traverse0 + +-- | \(\mathcal{O}(n)\). +-- Map each element in the tree to an action, evaluate these actions +-- left-to-right and collect the results. +traverseWithKey + :: Applicative f => (Build -> a -> f b) -> RadixTree a -> f (RadixTree b) +traverseWithKey = traverseWithKey0 + + + +-- | \(\mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filter :: (a -> Bool) -> RadixTree a -> RadixTree a +filter = filter0 + +-- | \(\mathcal{O}(n)\). +-- Filter values that satisfy the value predicate. +filterWithKey :: (Build -> a -> Bool) -> RadixTree a -> RadixTree a +filterWithKey = filterWithKey0 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +-- +-- The 'Maybe' is evaluated to WHNF. +mapMaybe :: (a -> Maybe b) -> RadixTree a -> RadixTree b +mapMaybe = mapMaybe0 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create one out of 'Just' values. +-- +-- The 'Maybe' is evaluated to WHNF. +mapMaybeWithKey :: (Build -> a -> Maybe b) -> RadixTree a -> RadixTree b +mapMaybeWithKey = mapMaybeWithKey0 + + +-- | \(\mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partition :: (a -> Bool) -> RadixTree a -> Split a a +partition = partition0 + +-- | \(\mathcal{O}(n)\). +-- Split the tree into two, such that values that satisfy the predicate +-- are on the left and values that do not are on the right. +partitionWithKey :: (Build -> a -> Bool) -> RadixTree a -> Split a a +partitionWithKey = partitionWithKey0 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +-- +-- The 'Either' is evaluated to WHNF. +mapEither :: (a -> Either b c) -> RadixTree a -> Split b c +mapEither = mapEither0 + +-- | \(\mathcal{O}(n)\). +-- Apply a function to every value in the tree and create two trees, +-- one out of 'Left' results and one out of 'Right' ones. +-- +-- The 'Either' is evaluated to WHNF. +mapEitherWithKey :: (Build -> a -> Either b c) -> RadixTree a -> Split b c +mapEitherWithKey = mapEitherWithKey0 + + + +{-# INLINE lookup #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the value at a key in the tree. +lookup :: Feed -> RadixTree a -> Maybe a +lookup = lookup0 + +{-# INLINE find #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the value at a key in the tree, falling back to the given default value +-- if it does not exist. +find :: a -> Feed -> RadixTree a -> a +find = find0 + +{-# INLINE member #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Check whether the value exists at a key in the tree. +member :: Feed -> RadixTree a -> Bool +member = member0 + +{-# INLINE subtree #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the part of the tree below the given prefix. +subtree :: Feed -> RadixTree a -> RadixTree a +subtree = subtree0 + +{-# INLINE prefix #-} +-- | \(\mathcal{O}(x)\). +-- Prefix the root of the tree with the given key. +prefix :: Feed -> RadixTree a -> RadixTree a +prefix = prefix0 + + +-- | \(\mathcal{O}(1)\). +-- Make a cursor that points to the root of the tree. +cursor :: RadixTree a -> Cursor a +cursor = cursor0 + +{-# INLINE move #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Move the cursor down by the extent of the given key. +move :: Feed -> Cursor a -> Cursor a +move = move0 + + + +{-# INLINE insert #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, it is replaced. +insert :: Feed -> a -> RadixTree a -> RadixTree a +insert = insert0 + +{-# INLINE insertWith #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, the function is used instead. +insertWith :: (a -> a) -> Feed -> a -> RadixTree a -> RadixTree a +insertWith = insertWith0 + +{-# INLINE insertWith' #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Insert a new value in the tree at the given key. +-- If a value already exists at that key, the function is used instead. +-- +-- New value is evaluated to WHNF. +insertWith' :: (a -> a) -> Feed -> a -> RadixTree a -> RadixTree a +insertWith' = insertWith0' + + +{-# INLINE adjust #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Apply a function to a value in the tree at the given key. +adjust :: (a -> a) -> Feed -> RadixTree a -> RadixTree a +adjust = adjust0 + +{-# INLINE adjust' #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Apply a function to a value in the tree at the given key. +-- +-- New value is evaluated to WHNF. +adjust' :: (a -> a) -> Feed -> RadixTree a -> RadixTree a +adjust' = adjust0' + + +{-# INLINE delete #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Delete a value in the tree at the given key. +delete :: Feed -> RadixTree a -> RadixTree a +delete = delete0 + +{-# INLINE prune #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Delete values in the tree below the given key. +prune :: Openness -> Feed -> RadixTree a -> RadixTree a +prune = prune0 + + +{-# INLINE update #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Update or delete a value in the tree at the given key. +-- +-- The 'Maybe' is evaluated to WHNF. +update :: (a -> Maybe a) -> Feed -> RadixTree a -> RadixTree a +update = update0 + + +{-# INLINE alter #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Insert, update or delete a value in the tree at the given key. +-- +-- The resulting 'Maybe' is evaluated to WHNF. +alter :: (Maybe a -> Maybe a) -> Feed -> RadixTree a -> RadixTree a +alter = alter0 + + +{-# INLINE shape #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Update the part of the tree at the given prefix. +-- +-- The resulting 'RadixTree' is evaluated to WHNF. +shape :: (RadixTree a -> RadixTree a) -> Feed -> RadixTree a -> RadixTree a +shape = shape0 + + +{-# INLINE splitLookup #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Split the tree into two, such that +-- values with keys smaller than the given one are on the left, +-- values with keys greater than the given one are on the right, +-- and the value at the given key is returned separately. +splitLookup :: Feed -> RadixTree a -> SplitLookup a a a +splitLookup = splitLookup0 + + + +{-# INLINE lookupL #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up a value at a largest key smaller than (or equal to) the given key. +lookupL :: Openness -> Feed -> RadixTree a -> Maybe (Lookup a) +lookupL = lookupL0 + + +{-# INLINE lookupR #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up a value at a smallest key greater than (or equal to) the given key. +lookupR :: Openness -> Feed -> RadixTree a -> Maybe (Lookup a) +lookupR = lookupR0 + + + +{-# INLINE adjustL #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +adjustL :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustL = adjustL0 + +{-# INLINE adjustL' #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +-- +-- New value is evaluated to WHNF. +adjustL' :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustL' = adjustL0' + +{-# INLINE adjustLWithKey #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +adjustLWithKey :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustLWithKey = adjustLWithKey0 + +{-# INLINE adjustLWithKey' #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Apply a function to every value for which the key is smaller than +-- (or equal to) the given one. +-- +-- New value is evaluated to WHNF. +adjustLWithKey' :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustLWithKey' = adjustLWithKey0' + + + +{-# INLINE adjustR #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +adjustR :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustR = adjustR0 + +{-# INLINE adjustR' #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +-- +-- New value is evaluated to WHNF. +adjustR' :: (a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustR' = adjustR0' + +{-# INLINE adjustRWithKey #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +adjustRWithKey :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustRWithKey = adjustRWithKey0 + +{-# INLINE adjustRWithKey' #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Apply a function to every value for which the key is greater than +-- (or equal to) the given one. +-- +-- New value is evaluated to WHNF. +adjustRWithKey' :: (Build -> a -> a) -> Openness -> Feed -> RadixTree a -> RadixTree a +adjustRWithKey' = adjustRWithKey0' + + + +{-# INLINE updateL #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Update every value for which the key is smaller than (or equal to) the given one. +updateL :: (a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateL = updateL0 + +{-# INLINE updateLWithKey #-} +-- | \(\mathcal{O}(\min(x,k) + n_L)\). +-- Update every value for which the key is smaller than (or equal to) the given one. +-- +-- The 'Maybe' is evaluated to WHNF. +updateLWithKey :: (Build -> a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateLWithKey = updateLWithKey0 + +{-# INLINE updateR #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Update every value for which the key is greater than (or equal to) the given one. +updateR :: (a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateR = updateR0 + +{-# INLINE updateRWithKey #-} +-- | \(\mathcal{O}(\min(x,k) + n_R)\). +-- Update every value for which the key is greater than (or equal to) the given one. +-- +-- The 'Maybe' is evaluated to WHNF. +updateRWithKey :: (Build -> a -> Maybe a) -> Openness -> Feed -> RadixTree a -> RadixTree a +updateRWithKey = updateRWithKey0 + + + +{-# INLINE takeL #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Take values for which keys are smaller than (or equal to) the given one. +takeL :: Openness -> Feed -> RadixTree a -> RadixTree a +takeL = takeL0 + +{-# INLINE takeR #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Take values for which keys are greater than (or equal to) the given one. +takeR :: Openness -> Feed -> RadixTree a -> RadixTree a +takeR = takeR0 + + + +{-# INLINE splitL #-} +-- | \(\mathcal{O}(\min(x,k))\). +-- Split the tree into two, such that +-- values with keys smaller than (or equal to) the given one are on the left, +-- and the rest are on the right. +splitL :: Openness -> Feed -> RadixTree a -> Split a a +splitL = splitL0 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +lookupMin :: RadixTree a -> Maybe a +lookupMin = lookupMin0 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the leftmost key in the tree. +lookupMinWithKey :: RadixTree a -> Maybe (Lookup a) +lookupMinWithKey = lookupMinWithKey0 + +-- | \(\mathcal{O}(k)\). +-- Delete a value at the leftmost key in the tree. +deleteMin :: RadixTree a -> RadixTree a +deleteMin = deleteMin0 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +adjustMin :: (a -> a) -> RadixTree a -> RadixTree a +adjustMin = adjustMin0 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +adjustMinWithKey :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMinWithKey = adjustMinWithKey0 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMin' :: (a -> a) -> RadixTree a -> RadixTree a +adjustMin' = adjustMin0' + +-- | \(\mathcal{O}(k)\). +-- Update a value at the leftmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMinWithKey' :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMinWithKey' = adjustMinWithKey0' + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +updateMin :: (a -> Maybe a) -> RadixTree a -> RadixTree a +updateMin = updateMin0 + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the leftmost key in the tree. +updateMinWithKey :: (Build -> a -> Maybe a) -> RadixTree a -> RadixTree a +updateMinWithKey = updateMinWithKey0 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the leftmost value and return it alongside the tree without it. +minView :: RadixTree a -> Maybe (ViewL a) +minView = minView0 + + + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +lookupMax :: RadixTree a -> Maybe a +lookupMax = lookupMax0 + +-- | \(\mathcal{O}(k)\). +-- Look up a value at the rightmost key in the tree. +lookupMaxWithKey :: RadixTree a -> Maybe (Lookup a) +lookupMaxWithKey = lookupMaxWithKey0 + +-- | \(\mathcal{O}(k)\). +-- Delete a value at the rightmost key in the tree. +deleteMax :: RadixTree a -> RadixTree a +deleteMax = deleteMax0 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +adjustMax :: (a -> a) -> RadixTree a -> RadixTree a +adjustMax = adjustMax0 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +adjustMaxWithKey :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMaxWithKey = adjustMaxWithKey0 + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMax' :: (a -> a) -> RadixTree a -> RadixTree a +adjustMax' = adjustMax0' + +-- | \(\mathcal{O}(k)\). +-- Update a value at the rightmost key in the tree. +-- +-- New value is evaluated to WHNF. +adjustMaxWithKey' :: (Build -> a -> a) -> RadixTree a -> RadixTree a +adjustMaxWithKey' = adjustMaxWithKey0' + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +updateMax :: (a -> Maybe a) -> RadixTree a -> RadixTree a +updateMax = updateMax0 + +-- | \(\mathcal{O}(k)\). +-- Update or delete a value at the rightmost key in the tree. +updateMaxWithKey :: (Build -> a -> Maybe a) -> RadixTree a -> RadixTree a +updateMaxWithKey = updateMaxWithKey0 + +-- | \(\mathcal{O}(\min(x,k))\). +-- Look up the rightmost value and return it alongside the tree without it. +maxView :: RadixTree a -> Maybe (ViewR a) +maxView = maxView0 + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Unbiased union of two trees. +union :: RadixTree a -> RadixTree a -> RadixTree a +union = union0 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Left-biased union of two trees. +unionL :: RadixTree a -> RadixTree a -> RadixTree a +unionL = unionL0 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Union of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +unionWith' :: (a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a +unionWith' = unionWith0' + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Union of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +unionWithKey' :: (Build -> a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a +unionWithKey' = unionWithKey0' + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees. +difference :: RadixTree a -> RadixTree b -> RadixTree a +difference = difference0 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees with a combining function. +-- +-- The 'Maybe' is evaluated to WHNF. +differenceWith + :: (a -> b -> Maybe a) -> RadixTree a -> RadixTree b -> RadixTree a +differenceWith = differenceWith0 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Difference of two trees with a combining function. +-- +-- The 'Maybe' is evaluated to WHNF. +differenceWithKey + :: (Build -> a -> b -> Maybe a) -> RadixTree a -> RadixTree b -> RadixTree a +differenceWithKey = differenceWithKey0 + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Compare two trees with respect to set inclusion, +-- using the given equality function for intersecting keys. +-- If any intersecting keys hold unequal values, the trees are 'Incomparable'. +compare :: (a -> b -> Bool) -> RadixTree a -> RadixTree b -> PartialOrdering +compare = compare0 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Determine whether two trees' key sets are disjoint. +disjoint :: RadixTree a -> RadixTree b -> Bool +disjoint = disjoint0 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Unbiased intersection of two trees. +intersection :: RadixTree a -> RadixTree a -> RadixTree a +intersection = intersection0 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Left-biased intersection of two trees. +intersectionL :: RadixTree a -> RadixTree b -> RadixTree a +intersectionL = intersectionL0 + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Intersection of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +intersectionWith' :: (a -> b -> c) -> RadixTree a -> RadixTree b -> RadixTree c +intersectionWith' = intersectionWith0' + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- Intersection of two trees with a combining function. +-- +-- New values are evaluated to WHNF. +intersectionWithKey' :: (Build -> a -> b -> c) -> RadixTree a -> RadixTree b -> RadixTree c +intersectionWithKey' = intersectionWithKey0' diff --git a/src/Data/RadixTree/Word8/Strict/Debug.hs b/src/Data/RadixTree/Word8/Strict/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Strict/Debug.hs @@ -0,0 +1,30 @@ +{-| + Safe functions for datatype introspection. + -} + +module Data.RadixTree.Word8.Strict.Debug + ( -- * Show + showsTree + + -- * Validate + , Validity (..) + , Reason (..) + , validate + ) where + +import Data.RadixNTree.Word8.Strict (RadixTree) +import Data.RadixNTree.Word8.Strict.Debug + + + +-- | \(\mathcal{O}(n)\). +-- Shows the internal structure of the tree. +showsTree :: (a -> ShowS) -> RadixTree a -> ShowS +showsTree = showsTree0 + + + +-- | \(\mathcal{O}(n)\). +-- Checks whether the tree is well-formed. +validate :: RadixTree a -> Validity +validate = validate0 diff --git a/src/Data/RadixTree/Word8/Strict/TH.hs b/src/Data/RadixTree/Word8/Strict/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Strict/TH.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +{-| + Template Haskell helper functions. + -} + +module Data.RadixTree.Word8.Strict.TH + ( sequenceCode + ) where + +import Data.RadixNTree.Word8.Strict.TH + +import Language.Haskell.TH.Syntax + + + +-- | \(\mathcal{O}(n)\). +-- Evaluate a tree of typed expressions. +sequenceCode :: Quote m => RadixTree (Code m a) -> Code m (RadixTree a) +sequenceCode = sequenceCode0 diff --git a/src/Data/RadixTree/Word8/Strict/Unsafe.hs b/src/Data/RadixTree/Word8/Strict/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/RadixTree/Word8/Strict/Unsafe.hs @@ -0,0 +1,71 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| + Data structure internals, helper operations and unsafe functions. + + == Implementation + + The tree is an altered 'Data.Patricia.Word.Strict.Unsafe.Patricia' tree. + + Each 'Tip' in the radix tree represents a continuous non-empty chunk of the key, + at the end of which there either exists a value or the rest of the key branches. + The first byte of the chunk corresponds to a 'Key' in a + 'Data.Patricia.Word.Strict.Unsafe.Patricia' tree, hence the definitions of + 'Bin' and 'Nil' remain unchanged. + + The only state the resulting 'Radix1Tree' is unable to represent is the + value at the root of the tree (for which the key is an empty byte sequence), + as such that value is prepended with a special 2-tuple named 'RadixTree'. + -} + +module Data.RadixTree.Word8.Strict.Unsafe + ( RadixTree (..) + , Radix1Tree (..) + + -- * Bit operations + , Prefix + , Key + + -- | === Compare + , beyond + , upper + , lower + + -- | === Create + , Mask + , zeroBit + , mask + , branchingBit + + -- * Exceptions + , MalformedTree (..) + + -- * Full-tree + -- ** Merge + , merge + ) where + +import Data.RadixNTree.Word8.Key +import Data.RadixNTree.Word8.Strict +import Radix.Exception +import Radix.Word8.Foundation + + + +-- | \(\mathcal{O}(n_A k_A + n_B k_B)\). +-- General merge of two trees. +-- +-- Resulting 'Maybe's and 'Radix1Tree's in argument functions are evaluated to WHNF. +-- +-- This functions inlines when all argument functions are provided. +{-# INLINE merge #-} +merge + :: (Build -> a -> b -> Maybe c) -- ^ Single value collision + -> (Build -> a -> Maybe c) -- ^ Single left value + -> (Build -> Radix1Tree a -> Radix1Tree c) -- ^ Left subtree + -> (Build -> b -> Maybe c) -- ^ Single right value + -> (Build -> Radix1Tree b -> Radix1Tree c) -- ^ Right subtree + -> RadixTree a + -> RadixTree b + -> RadixTree c +merge = merge0 diff --git a/src/Data/Zebra/Word.hs b/src/Data/Zebra/Word.hs new file mode 100644 --- /dev/null +++ b/src/Data/Zebra/Word.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE PatternSynonyms #-} + +{-| + @'Zebra'@ is a fully-strict one-dimensional space partitioning tree, + using 'Data.Word.Word's as keys. + + == Laziness + + Evaluating the root of the tree (i.e. @(_ :: 'Zebra')@) to + weak head normal form evaluates the entire tree to normal form. + + == Performance + + Each function's time complexity is provided in the documentation. + + \(n\) refers to the total number of space partitions in the tree. + Parts of the tree are denoted using subscripts: \(n_L\) refers to the left side, + \(n_R\) to the right side, and \(n_I\) to a range (interval). + + \(W\) is the size of 'Word' in bits, i.e. @'Data.Bits.finiteBitSize' (0 :: 'Word')@. + + == Implementation + + See the implementation section in "Data.Zebra.Word.Unsafe" for the explanation of + the innerworkings. + + See the implementation section in "Data.Patricia.Word.Strict" for literary references. + -} + +module Data.Zebra.Word + ( Zebra + , Color (..) + + -- * Construct + , pattern Mono + + -- * Single-key + -- ** Lookup + , Data.Zebra.Word.Internal.lookup + + -- * Directional + -- ** Size + -- | === Left + , monoL + , sizeL + + -- | === Right + , monoR + , sizeR + + -- ** Lookup + -- | === Left + , lookupL + , findL + + -- | === Right + , lookupR + , findR + + -- ** Insert + -- | === Left + , fillL + + -- | === Right + , fillR + + -- ** Fold + -- | === Left-to-right + + -- | ===== Left + , foldlL + , foldlL' + + -- | ===== Right + , foldlR + , foldlR' + + -- | === Right-to-left + + -- | ===== Left + , foldrL + , foldrL' + + -- | ===== Right + , foldrR + , foldrR' + + -- * Range + , Range (Range) + + -- ** Size + , monoRange + , sizeRange + + -- ** Insert + , fillRange + + -- ** Fold + -- | === Left-to-right + , foldlRange + , foldlRange' + + -- | === Right-to-left + , foldrRange + , foldrRange' + + -- * Full tree + -- ** Size + , size + + -- ** Fold + -- | === Left-to-right + , Data.Zebra.Word.Internal.foldl + , Data.Zebra.Word.Internal.foldl' + + -- | === Right-to-right + , Data.Zebra.Word.Internal.foldr + , Data.Zebra.Word.Internal.foldr' + + -- ** Complement + , complement + + -- ** Compare + , PartialOrdering (..) + , Data.Zebra.Word.Internal.compare + + -- ** Union + , union + + -- ** Difference + , difference + , symmetricDifference + + -- ** Intersection + , disjoint + , intersection + ) where + +import Data.Zebra.Word.Internal +import Radix.Common diff --git a/src/Data/Zebra/Word/Debug.hs b/src/Data/Zebra/Word/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Data/Zebra/Word/Debug.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE BangPatterns #-} + +{-| + Safe functions for datatype introspection. + -} + +module Data.Zebra.Word.Debug + ( -- * Show + showsTree + + -- * Validate + , Validity (..) + , Reason (..) + , validate + ) where + +import Data.Zebra.Word.Internal +import Numeric.Long +import Radix.Word.Foundation +import Radix.Word.Debug + + + +-- | \(\mathcal{O}(n)\). +-- Shows the internal structure of the tree. +showsTree :: Zebra -> ShowS +showsTree = go 0 + where + go i t = + mappend (replicate i ' ') . + case t of + Bin p l r -> + showString "Bin " . showPrefix p . showChar '\n' + . go (i + 2) l . showChar '\n' + . go (i + 2) r + + Bla k -> goTip Black k + Whi k -> goTip White k + + Nil c -> showString "Nil " . showChar (color c) + + goTip c k = + showString "Tip " . showLongBin k . showString " => " . showChar (color c) + + color Black = 'B' + color White = 'W' + + + +-- | Whether the tree is well-formed. +data Validity = Valid + | Invalid Reason + deriving Show + +-- | Reason for why the tree is considered malformed. +data Reason = -- | Prefix is @0@. + ZeroPrefix + -- | Prefix below diverges from the prefix above + | PrefixBelow Prefix Prefix + -- | Key diverges the prefix above + | KeyBelow Prefix Key + -- | Nil is in the tree. + | FoundNil + -- | Tip has a value of zero despite not being the root. + | ZeroKey + -- | Key has the same color as the key to the left of it. + | NoSwitch Color Key + deriving Show + +data Carry = Carry Color + | Break Reason + +-- | \(\mathcal{O}(n)\). +-- Checks whether the tree is well-formed. +validate :: Zebra -> Validity +validate t0 = + case go0 t0 of + Carry _ -> Valid + Break r -> Invalid r + where + go0 t = + case t of + Bin p l r + | p == 0 -> Break ZeroPrefix + | otherwise -> + case go L p l Nothing of + Carry cR -> go R p r (Just cR) + err -> err + + Bla _ -> Carry Black + Whi _ -> Carry White + + Nil _ -> Break FoundNil + + 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 -> + case go L p l cL of + Carry cR -> go R p r (Just cR) + err -> err + + Bla k -> goTip s q k cL Black + Whi k -> goTip s q k cL White + + 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 diff --git a/src/Data/Zebra/Word/Internal.hs b/src/Data/Zebra/Word/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Zebra/Word/Internal.hs @@ -0,0 +1,2906 @@ +{-# LANGUAGE BangPatterns + , PatternSynonyms + , ViewPatterns + , UnboxedTuples + , UnboxedSums #-} + +module Data.Zebra.Word.Internal + ( Color (..) + , Zebra (Mono, ..) + + , Data.Zebra.Word.Internal.lookup + , lookupL + , findL + , lookupR + , findR + + , Range (..) + + , monoL + , monoR + , monoRange + + , unsafeMonoRange + + , size + + , sizeL + , sizeR + , sizeRange + + , unsafeSize + , unsafeSizeL + , unsafeSizeR + , unsafeSizeRange + + , fillL + , fillR + , fillRange + + , unsafeFillL + , unsafeFillRange + + , Data.Zebra.Word.Internal.foldl + , foldlL + , foldlR + , foldlRange + , unsafeFoldlRange + + , Data.Zebra.Word.Internal.foldr + , foldrL + , foldrR + , foldrRange + , unsafeFoldrRange + + , Data.Zebra.Word.Internal.foldl' + , foldlL' + , foldlR' + , foldlRange' + , unsafeFoldlRange' + + , Data.Zebra.Word.Internal.foldr' + , foldrL' + , foldrR' + , foldrRange' + , unsafeFoldrRange' + + , Data.Zebra.Word.Internal.complement + + , union + , disjoint + , intersection + + , difference + , symmetricDifference + + , Data.Zebra.Word.Internal.compare + ) where + +import Radix.Common (PartialOrdering (..), order) +import Radix.Word.Common +import Radix.Word.Foundation + +import Data.Bits +import Numeric.Natural + + + +-- | Space partition colors. +data Color = Black + | White + deriving (Show, Eq) + +invert :: Color -> (# Color #) +invert Black = (# White #) +invert White = (# Black #) + + + +-- | Fully-strict one-dimensional space partitioning tree. +data Zebra = Bin + {-# UNPACK #-} !Prefix + !Zebra -- ^ Masked bit is @0@. + !Zebra -- ^ Masked bit is not @0@. + + | Bla + -- | Invariant: can only be @0@ as the root of the tree. + {-# UNPACK #-} !Key + + | Whi + -- | Invariant: can only be @0@ as the root of the tree. + {-# UNPACK #-} !Key + + | Nil -- ^ Invariant: unreachable state. + {-# UNPACK #-} !Color + +-- | Tree is represented as a list of closed intervals of all 'White' keys. +instance Show Zebra where + showsPrec _ = + let f (UnsafeRange kL kR) c z = + case c of + Black -> z + White -> (kL, kR) : z + + in showList . Data.Zebra.Word.Internal.foldr f [] + +instance Eq Zebra where + (==) = go + where + go l r = + case l of + Bin p xl xr -> + case r of + Bin q yl yr -> p == q && go xl yl && go xr yr + _ -> False + + Bla kA -> + case r of + Bla kB -> kA == kB + _ -> False + + Whi kA -> + case r of + Whi kB -> kA == kB + _ -> False + + Nil _ -> False + + + +-- | \(\mathcal{O}(1)\). +-- All keys are the same color. +pattern Mono :: Color -> Zebra +pattern Mono c <- ( ( \z -> case z of + Bla 0 -> Just Black + Whi 0 -> Just White + _ -> Nothing + ) + -> Just c + ) + where + Mono Black = Bla 0 + Mono White = Whi 0 + + + +{-# INLINE join #-} +-- | Knowing that the prefices of two non-'Nil' trees disagree, construct a 'Bin'. +join :: Prefix -> Zebra -> Prefix -> Zebra -> Zebra +join p0 t0 p1 t1 = + let m = branchingBit p0 p1 + + p = mask p0 m .|. m + + in if zeroBit p0 m + then Bin p t0 t1 + else Bin p t1 t0 + +{-# INLINE rebin #-} +-- | Reconstruct a 'Bin' knowing that either of the sides may now be a 'Nil'. +rebin :: Prefix -> Zebra -> Zebra -> Zebra +rebin p l r = + case l of + Nil _ -> r + _ -> + case r of + Nil _ -> l + _ -> Bin p l r + +{-# INLINE rebinL #-} +-- | Reconstruct a 'Bin' knowing that the left side may now be a 'Nil'. +rebinL :: Prefix -> Zebra -> Zebra -> Zebra +rebinL p l r = + case l of + Nil _ -> r + _ -> Bin p l r + + +{-# INLINE rebinR #-} +-- | Reconstruct a 'Bin' knowing that the right side may now be a 'Nil'. +rebinR :: Prefix -> Zebra -> Zebra -> Zebra +rebinR p l r = + case r of + Nil _ -> l + _ -> Bin p l r + +{-# INLINE tip #-} +tip :: Key -> Color -> Zebra +tip k Black = Bla k +tip k White = Whi k + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Check whether all keys smaller than or equal to the given key are of the same color. +monoL :: Word -> Zebra -> Maybe Color +monoL !w = go + where + go t = + case t of + Bin p l _ -> + if w < p + then if w >= lower p + then go l + else let !(# cR #) = colorL l + !(# cL #) = invert cR + in Just cL + + else Nothing + + Bla k -> goTip Black k + Whi k -> goTip White k + Nil _ -> Nothing + + goTip c k + | k == 0 = Just c + | w < k = let !(# x #) = invert c + in Just x + | otherwise = Nothing + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Check whether all keys greater than or equal to the given key are of the same color. +monoR :: Word -> Zebra -> Maybe Color +monoR !w = go + where + go t = + case t of + Bin p _ r -> + if w < p + then Nothing + else if w <= upper p + then go r + else let !(# cR #) = colorR r + in Just cR + + Bla k -> goTip Black k + Whi k -> goTip White k + Nil _ -> Nothing + + goTip c k + | w >= k = Just c + | otherwise = Nothing + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Check whether all keys in the range are of the same color. +monoRange :: Range -> Zebra -> Maybe Color +monoRange (UnsafeRange kL kR) + | kR == maxBound = monoR kL + | otherwise = unsafeMonoRange kL (kR + 1) + +-- | \(\mathcal{O}(\min(n,W))\). +-- Check whether all keys in the range are of the same color. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeMonoRange + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Zebra + -> Maybe Color +unsafeMonoRange !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> let !mcL = monoR wL l + !mcR = monoL wR r + + in if mcL == mcR + then mcL + else Nothing + + LT | pM <= upper p -> go r + | p >= lower pM -> if wL >= p + then monoR wL r + else Nothing + + | otherwise -> let !(# cR #) = colorR r + in Just cR + + GT | p <= upper pM -> if wR <= p + then monoL wR l + else Nothing + + | pM >= lower p -> go l + | otherwise -> let !(# cR #) = colorL l + !(# cL #) = invert cR + in Just cL + + Bla k -> goTip Black k + Whi k -> goTip White k + Nil _ -> Nothing + + goTip c k + | wL >= k = Just c + | wR <= k = let !(# x #) = invert c + in Just x + | otherwise = Nothing + + + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of keys of the given color. +-- The returned number is guaranteed to be in the \([0, 2^W]\) interval. +size :: Color -> Zebra -> Natural +size !x t = + case t of + Bla 0 -> goZero Black + Whi 0 -> goZero White + _ -> fromIntegral $ unsafeSize x t + where + goZero c + | x == c = fromIntegral (maxBound :: Word) + 1 + | otherwise = 0 + +-- | \(\mathcal{O}(n)\). +-- Calculate the number of keys of the given color. +-- +-- The tree __must not__ be 'Mono'. +unsafeSize :: Color -> Zebra -> Word +unsafeSize !x = size_ x 0 0 + +size_ :: Color -> Word -> Word -> Zebra -> Word +size_ !x = go + where + go !kL !kR t = + case t of + Bin p l r -> + let !nL = go kL p l + !nR = go p kR r + + in nL + nR + + Bla k -> goTip kL kR k Black + Whi k -> goTip kL kR k White + + Nil _ -> 0 + + goTip !kL !kR k c + | x == c = kR - k + | otherwise = k - kL + + + +-- | \(\mathcal{O}(\min(n,W) + n_L)\). +-- Calculate the number of keys of the given color that are smaller than +-- or equal to the given key. +-- The returned number is guaranteed to be in the \([0, 2^W]\) interval. +sizeL :: Color -> Word -> Zebra -> Natural +sizeL x w + | w == maxBound = size x + | otherwise = fromIntegral . unsafeSizeL x (w + 1) + +-- | \(\mathcal{O}(\min(n,W) + n_L)\). +-- Calculate the number of keys of the given color that are smaller than the given key. +-- +-- The given key __must not__ be equal to @'Data.Bits.maxBound'@. +unsafeSizeL :: Color -> Word -> Zebra -> Word +unsafeSizeL x w = sizeL_ x 0 w + +sizeL_ :: Color -> Word -> Word -> Zebra -> Word +sizeL_ !x !kL0 !w = go kL0 + where + go !kL t = + case t of + Bin p l r -> + if w < p + then go kL l + else + let !nL = size_ x kL p l + !nR = go p r + + in nL + nR + + Bla k -> goTip kL k Black + Whi k -> goTip kL k White + + Nil _ -> 0 + + goTip !kL k c + | x == c = if w > k + then w - k + else 0 + + | otherwise = let i | w > k = k + | otherwise = w + + in i - kL + + + +-- | \(\mathcal{O}(\min(n,W) + n_R)\). +-- Calculate the number of keys of the given color that are greater than +-- or equal to the given key. +-- The returned number is guaranteed to be in the \([0, 2^W]\) interval. +sizeR :: Color -> Word -> Zebra -> Natural +sizeR x w + | w == 0 = size x + | otherwise = fromIntegral . unsafeSizeR x w + +-- | \(\mathcal{O}(\min(n,W) + n_R)\). +-- Calculate the number of keys of the given color that are greater than +-- or equal to the given key. +-- +-- The given key __must not__ be @0@. +unsafeSizeR :: Color -> Word -> Zebra -> Word +unsafeSizeR x w = sizeR_ x w 0 + +sizeR_ :: Color -> Word -> Word -> Zebra -> Word +sizeR_ !x !w = go + where + go !kR t = + case t of + Bin p l r -> + if w < p + then let !nL = go p l + !nR = size_ x p kR r + + in nL + nR + + else go kR r + + Bla k -> goTip kR k Black + Whi k -> goTip kR k White + + Nil _ -> 0 + + goTip kR k c + | x == c = kR - if w > k + then w + else k + + | otherwise = if w < k + then k - w + else 0 + + + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Calculate the number of keys of the given color in the range. +sizeRange :: Color -> Range -> Zebra -> Natural +sizeRange x (UnsafeRange kL kR) + | kR == maxBound = sizeR x kL + | otherwise = fromIntegral . unsafeSizeRange x kL (kR + 1) + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Calculate the number of keys of the given color in the \([k_L, k_R)\) interval. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeSizeRange + :: Color + -> Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Zebra + -> Word +unsafeSizeRange !x !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> let !n = sizeR_ x wL p l + !m = sizeL_ x p wR r + + in n + m + + LT | pM <= upper p -> go r + | p >= lower pM -> if wL < p + then let !n = sizeR_ x wL p l + !m = size_ x p wR r + + in n + m + + else sizeR_ x wL wR r + + | otherwise -> let !(# cR #) = colorR r + in if cR == x + then wR - wL + else 0 + + GT | p <= upper pM -> if wR >= p + then let !n = size_ x wL p l + !m = sizeL_ x p wR r + + in n + m + + else sizeL_ x wL wR l + + | pM >= lower p -> go l + | otherwise -> let !(# cR #) = colorL l + in if cR == x + then 0 + else wR - wL + + Bla k -> goTip k Black + Whi k -> goTip k White + + Nil _ -> 0 + + goTip k c + | x == c = if wR >= k + then wR - if wL > k + then wL + else k + else 0 + + | otherwise = if wL <= k + then let i | wR > k = k + | otherwise = wR + + in i - wL + + else 0 + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold left-to-right over the ranges. +foldl :: (a -> Range -> Color -> a) -> a -> Zebra -> a +foldl f = \z t -> + case t of + Bin _ l r -> let !(# w', x', z' #) = foldl_L 0 f z l + in foldl_R maxBound f w' x' z' r + + Bla k -> tipM z k Black + Whi k -> tipM z k White + Nil _ -> z + where + tipM z k c + | k == 0 = let !r = UnsafeRange 0 maxBound + in f z r c + + | otherwise = let z' = let !k' = k - 1 + + !(# x #) = invert c + + in f z (UnsafeRange 0 k') x + + in f z' (UnsafeRange k maxBound) c + +foldl_L :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> (# Word, Color, a #) +foldl_L !wL f = go + where + go z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = go z l + in foldl_M f w' x' z' r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# 0, Black, z #) + where + goTip k c = (# k, c, if k == 0 + then z + else let !k' = k - 1 + + !(# x #) = invert c + + in f z (UnsafeRange wL k') x + #) + +foldl_R :: Word -> (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> a +foldl_R !wR f = go + where + go !w !x z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = foldl_M f w x z l + in go w' x' z' r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c = let z' = let !k' = k - 1 + in f z (UnsafeRange w k') x + + !r' = UnsafeRange k wR + + in f z' r' c + +foldl_M :: (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> (# Word, Color, a #) +foldl_M f = go + where + go w x z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = go w x z l + in go w' x' z' r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# w, x, z #) + where + goTip k c = (# k, c, let !k' = k - 1 + in f z (UnsafeRange w k') x + #) + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold left-to-right over the ranges of all the keys smaller than +-- or equal to the given one. +foldlL :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlL = foldlL_ 0 + +foldlL_ :: Word -> Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlL_ !wL !wR f = go + where + go z t = + case t of + Bin p l r -> + if wR < p + then go z l + else let !(# w', x', z' #) = foldl_L wL f z l + in foldlL_R wR f w' x' z' r + + Bla k -> tipM k Black + Whi k -> tipM k White + Nil _ -> z + where + tipM k c + | k == 0 = let !r = UnsafeRange wL wR + in f z r c + + | otherwise = + let !(# x #) = invert c + in if wR < k + then f z (UnsafeRange wL wR) x + else let z' = let !k' = k - 1 + in f z (UnsafeRange wL k') x + + in f z' (UnsafeRange k wR) c + +foldlL_R :: Word -> (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> a +foldlL_R !wR f = go + where + go !w !x z t = + case t of + Bin p l r -> + if wR < p + then go w x z l + else let !(# w', x', z' #) = foldl_M f w x z l + in go w' x' z' r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | wR < k = let !r = UnsafeRange w wR + in f z r x + + | otherwise = let z' = let !k' = k - 1 + in f z (UnsafeRange w k') x + + in f z' (UnsafeRange k wR) c + + + +-- | \(\mathcal{O}(n_R)\). +-- Fold left-to-right over the ranges of all the keys greater than +-- or equal to the given one. +foldlR :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlR wL = foldlR_ wL maxBound + +foldlR_ :: Word -> Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlR_ !wL !wR f = go + where + go z t = + case t of + Bin p l r -> + if wL < p + then let !(# w', x', z' #) = foldlR_L wL f z l + in foldl_R wR f w' x' z' r + + else go z r + + Bla k -> tipM k Black + Whi k -> tipM k White + Nil _ -> z + where + tipM k c + | wL >= k = f z (UnsafeRange wL wR) c + | otherwise = let !k' = k - 1 + !(# x #) = invert c + + z' = f z (UnsafeRange wL k') x + + in f z' (UnsafeRange k wR) c + +foldlR_L :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> (# Word, Color, a #) +foldlR_L !wL f = go + where + go z t = + case t of + Bin p l r -> + if wL < p + then let !(# w', x', z' #) = go z l + in foldl_M f w' x' z' r + + else go z r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# 0, Black, z #) + where + goTip k c + | wL >= k = (# wL, c, z #) + + | otherwise = let !k' = k - 1 + !(# x #) = invert c + + in (# k, c, f z (UnsafeRange wL k') x #) + + + +-- | \(\mathcal{O}(\min(n,W) + n_{I_R})\). +-- Fold left-to-right over the ranges of all the keys in the given range. +foldlRange :: Range -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlRange (UnsafeRange wL wR) f z + | wL == wR = \t -> let !c = Data.Zebra.Word.Internal.lookup wL t + in f z (UnsafeRange wL wR) c + + | otherwise = unsafeFoldlRange wL wR f z + +-- | \(\mathcal{O}(n)\). +-- Fold left-to-right over the ranges of all the keys +-- in the \([k_L, k_R)\) interval. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeFoldlRange + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> (a -> Range -> Color -> a) + -> a + -> Zebra + -> a +unsafeFoldlRange !wL !wR f = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go z t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> let !(# w', x', z' #) = foldlR_L wL f z l + in foldlL_R wR f w' x' z' r + + LT | pM <= upper p -> go z r + | p >= lower pM -> if wL < p + then let !(# w', x', z' #) = foldlR_L wL f z l + in foldl_R wR f w' x' z' r + + else foldlR_ wL wR f z r + + | otherwise -> let !(# cR #) = colorR r + in f z (UnsafeRange wL wR) cR + + GT | p <= upper pM -> if wR >= p + then let !(# w', x', z' #) = foldl_L wL f z l + in foldlL_R wR f w' x' z' r + + else foldlL_ wL wR f z l + + | pM >= lower p -> go z l + | otherwise -> let !(# cR #) = colorL l + !(# cL #) = invert cR + + in f z (UnsafeRange wL wR) cL + + Bla k -> tipM k Black + Whi k -> tipM k White + Nil _ -> z + where + tipM k c + | wL >= k = f z (UnsafeRange wL wR) c + | otherwise = + let !(# x #) = invert c + in if wR < k + then f z (UnsafeRange wL wR) x + else let !k' = k - 1 + + z' = f z (UnsafeRange wL k') x + + in f z' (UnsafeRange k wR) c + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold right-to-left over the ranges. +foldr :: (Range -> Color -> a -> a) -> a -> Zebra -> a +foldr f = \z t -> + case t of + Bin _ l r -> let !(# w', x', z' #) = foldr_R maxBound f z r + in foldr_L 0 f w' x' z' l + + Bla k -> goTip z k Black + Whi k -> goTip z k White + Nil _ -> z + where + goTip z k c + | k == 0 = f (UnsafeRange 0 maxBound) c z + + | otherwise = let !k' = k - 1 + + !(# x #) = invert c + + in f (UnsafeRange 0 k') x $ f (UnsafeRange k maxBound) c z + +foldr_R :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> (# Word, Color, a #) +foldr_R !wR f = go + where + go z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = go z r + in foldr_M f w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# 0, Black, z #) + where + goTip k c = let !k' = k - 1 + in (# k', c, f (UnsafeRange k wR) c z #) + +foldr_L :: Word -> (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> a +foldr_L !wL f = go + where + go !w !x z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = foldr_M f w x z r + in go w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | k == 0 = f (UnsafeRange wL w) c z + + | otherwise = let !k' = k - 1 + in f (UnsafeRange wL k') x $ f (UnsafeRange k w) c z + +foldr_M + :: (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> (# Word, Color, a #) +foldr_M f = go + where + go w x z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = go w x z r + in go w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# w, x, z #) + where + goTip k c = let !k' = k - 1 + in (# k', c, f (UnsafeRange k w) c z #) + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold right-to-left over the ranges of all the keys greater than +-- or equal to the given one. +foldrR :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrR wL = foldrR_ wL maxBound + +foldrR_ :: Word -> Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrR_ !wL !wR f = go + where + go z t = + case t of + Bin p l r -> + if wL < p + then let !(# w', x', z' #) = foldr_R wR f z r + in foldrR_L wL f w' x' z' l + + else go z r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | k == 0 = f (UnsafeRange wL wR) c z + + | wL < k = let !k' = k - 1 + + !(# x #) = invert c + + in f (UnsafeRange wL k') x $ f (UnsafeRange k wR) c z + + | otherwise = f (UnsafeRange wL wR) c z + +foldrR_L :: Word -> (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> a +foldrR_L !wL f = go + where + go !w !x z t = + case t of + Bin p l r -> + if wL < p + then let !(# w', x', z' #) = foldr_M f w x z r + in go w' x' z' l + + else go w x z r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | wL < k = let !k' = k - 1 + in f (UnsafeRange wL k') x $ f (UnsafeRange k w) c z + + | otherwise = f (UnsafeRange wL w) c z + + + +-- | \(\mathcal{O}(n_L)\). +-- Fold right-to-left over the ranges of all the keys smaller than +-- or equal to the given one. +foldrL :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrL = foldrL_ 0 + +foldrL_ :: Word -> Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrL_ !wL !wR f = go + where + go z t = + case t of + Bin p l r -> + if wR < p + then go z l + else let !(# w', x', z' #) = foldrL_R wR f z r + in foldr_L wL f w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | k == 0 = f (UnsafeRange wL wR) c z + + | wR >= k = let !k' = k - 1 + + !(# x #) = invert c + + in f (UnsafeRange wL k') x $ f (UnsafeRange k wR) c z + + | otherwise = let !(# x #) = invert c + in f (UnsafeRange wL wR) x z + +foldrL_R :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> (# Word, Color, a #) +foldrL_R !wR f = go + where + go z t = + case t of + Bin p l r -> + if wR < p + then go z l + else let !(# w', x', z' #) = go z r + in foldr_M f w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# 0, Black, z #) + where + goTip k c + | wR >= k = let !k' = k - 1 + in (# k', c, f (UnsafeRange k wR) c z #) + + | otherwise = (# wR, c, z #) + + + +-- | \(\mathcal{O}(\min(n,W) + n_{I_L})\). +-- Fold right-to-left over the ranges of all the keys in the given range. +foldrRange :: Range -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrRange (UnsafeRange wL wR) f z + | wL == wR = \t -> let !c = Data.Zebra.Word.Internal.lookup wL t + in f (UnsafeRange wL wR) c z + + | otherwise = unsafeFoldrRange wL wR f z + +-- | \(\mathcal{O}(\min(n,W) + n_{I_L})\). +-- Fold right-to-left over the ranges of all the keys +-- in the \([k_L, k_R)\) interval. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeFoldrRange + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> (Range -> Color -> a -> a) + -> a + -> Zebra + -> a +unsafeFoldrRange !wL !wR f = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go z t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> let !(# w', x', z' #) = foldrL_R wR f z r + in foldrR_L wL f w' x' z' l + + LT | pM <= upper p -> go z r + | p >= lower pM -> if wL < p + then let !(# w', x', z' #) = foldrL_R wR f z r + in foldr_L wL f w' x' z' l + + else foldrR_ wL wR f z r + + | otherwise -> let !(# cR #) = colorR r + in f (UnsafeRange wL wR) cR z + + GT | p <= upper pM -> if wR >= p + then let !(# w', x', z' #) = foldr_R wR f z r + in foldrR_L wL f w' x' z' l + + else foldrL_ wL wR f z l + + | pM >= lower p -> go z l + + | otherwise -> let !(# cR #) = colorL l + !(# cL #) = invert cR + + in f (UnsafeRange wL wR) cL z + + Bla k -> tipM k Black + Whi k -> tipM k White + Nil _ -> z + where + tipM k c + | wL >= k = f (UnsafeRange wL wR) c z + | otherwise = + let !(# x #) = invert c + in if wR < k + then f (UnsafeRange wL wR) x z + else let !k' = k - 1 + in f (UnsafeRange wL k') x $ f (UnsafeRange k wR) c z + + + +-- | \(\mathcal{O}(n)\). +-- Fold left-to-right over the ranges with a strict accumulator. +foldl' :: (a -> Range -> Color -> a) -> a -> Zebra -> a +foldl' f = \ !z t -> + case t of + Bin _ l r -> let !(# w', x', z' #) = foldl'_L 0 f z l + in foldl'_R maxBound f w' x' z' r + + Bla k -> goTip z k Black + Whi k -> goTip z k White + Nil _ -> z + where + goTip z k c + | k == 0 = f z (UnsafeRange 0 maxBound) c + + | otherwise = let !z' = let !k' = k - 1 + + !(# x #) = invert c + + in f z (UnsafeRange 0 k') x + + in f z' (UnsafeRange k maxBound) c + +foldl'_L :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> (# Word, Color, a #) +foldl'_L !wL f = go + where + go !z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = go z l + in foldl'_M f w' x' z' r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# 0, Black, z #) + where + goTip k c = let !k' = k - 1 + + !(# x #) = invert c + + in (# k, c, if k == 0 + then z + else f z (UnsafeRange wL k') x #) + +foldl'_R :: Word -> (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> a +foldl'_R !wR f = go + where + go !w !x !z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = foldl'_M f w x z l + in go w' x' z' r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c = let !z' = f z (UnsafeRange w (k - 1)) x + in f z' (UnsafeRange k wR) c + +foldl'_M + :: (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> (# Word, Color, a #) +foldl'_M f = go + where + go w x !z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = go w x z l + in go w' x' z' r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# w, x, z #) + where + goTip k c = (# k, c, f z (UnsafeRange w (k - 1)) x #) + + + +-- | \(\mathcal{O}(n)\). +-- Fold left-to-right over the ranges of all the keys smaller than +-- or equal to the given one. +foldlL' :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlL' = foldlL'_ 0 + +foldlL'_ :: Word -> Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlL'_ !wL !wR f = go + where + go !z t = + case t of + Bin p l r -> + if wR < p + then go z l + else let !(# w', x', z' #) = foldl'_L wL f z l + in foldlL'_R wR f w' x' z' r + + Bla k -> tipM k Black + Whi k -> tipM k White + Nil _ -> z + where + tipM k c + | k == 0 = f z (UnsafeRange wL wR) c + + | wR < k = let !(# x #) = invert c + in f z (UnsafeRange wL wR) x + + | otherwise = let !z' = let !k' = k - 1 + + !(# x #) = invert c + + in f z (UnsafeRange wL k') x + + in f z' (UnsafeRange k wR) c + +foldlL'_R :: Word -> (a -> Range -> Color -> a) -> Word -> Color -> a -> Zebra -> a +foldlL'_R !wR f = go + where + go !w !x !z t = + case t of + Bin p l r -> + if wR < p + then go w x z l + else let !(# w', x', z' #) = foldl'_M f w x z l + in go w' x' z' r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | wR < k = f z (UnsafeRange w wR) x + | otherwise = let z' = f z (UnsafeRange w (k - 1)) x + in f z' (UnsafeRange k wR) c + + + +-- | \(\mathcal{O}(n)\). +-- Fold left-to-right over the ranges of all the keys greater than +-- or equal to the given one. +foldlR' :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlR' wL = foldlR'_ wL maxBound + +foldlR'_ :: Word -> Word -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlR'_ !wL !wR f = go + where + go !z t = + case t of + Bin p l r -> + if wL < p + then let !(# w', x', z' #) = foldlR'_L wL f z l + in foldl'_R wR f w' x' z' r + + else go z r + + Bla k -> tipM k Black + Whi k -> tipM k White + Nil _ -> z + where + tipM k c + | wL >= k = f z (UnsafeRange wL wR) c + | otherwise = let !z' = let !k' = k - 1 + + !(# x #) = invert c + + in f z (UnsafeRange wL k') x + + in f z' (UnsafeRange k wR) c + +foldlR'_L :: Word -> (a -> Range -> Color -> a) -> a -> Zebra -> (# Word, Color, a #) +foldlR'_L !wL f = go + where + go !z t = + case t of + Bin p l r -> + if wL < p + then let !(# w', x', z' #) = go z l + in foldl'_M f w' x' z' r + + else go z r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# 0, Black, z #) + where + goTip k c + | wL >= k = (# wL, c, z #) + | otherwise = let !k' = k - 1 + + !(# x #) = invert c + + in (# k, c, f z (UnsafeRange wL k') x #) + + + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Fold left-to-right over the ranges of all the keys in the given range. +foldlRange' :: Range -> (a -> Range -> Color -> a) -> a -> Zebra -> a +foldlRange' (UnsafeRange wL wR) f z + | wL == wR = \t -> let !c = Data.Zebra.Word.Internal.lookup wL t + in f z (UnsafeRange wL wR) c + + | otherwise = unsafeFoldlRange' wL wR f z + +-- | \(\mathcal{O}(n)\). +-- Fold left-to-right over the ranges of all the keys +-- in the \([k_L, k_R)\) interval. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeFoldlRange' + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> (a -> Range -> Color -> a) + -> a + -> Zebra + -> a +unsafeFoldlRange' !wL !wR f = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go z t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> let !(# w', x', z' #) = foldlR'_L wL f z l + in foldlL'_R wR f w' x' z' r + + LT | pM <= upper p -> go z r + | p >= lower pM -> if wL < p + then let !(# w', x', z' #) = foldlR'_L wL f z l + in foldl'_R wR f w' x' z' r + + else foldlR'_ wL wR f z r + + | otherwise -> let !(# cR #) = colorR r + in f z (UnsafeRange wL wR) cR + + GT | p <= upper pM -> if wR >= p + then let !(# w', x', z' #) = foldl'_L wL f z l + in foldlL'_R wR f w' x' z' r + + else foldlL'_ wL wR f z l + + | pM >= lower p -> go z l + | otherwise -> let !(# cR #) = colorL l + !(# cL #) = invert cR + + in f z (UnsafeRange wL wR) cL + + Bla k -> tipM k Black + Whi k -> tipM k White + Nil _ -> z + where + tipM k c + | wL >= k = f z (UnsafeRange wL wR) c + | otherwise = + let !(# x #) = invert c + in if wR < k + then f z (UnsafeRange wL wR) x + else let !k' = k - 1 + + z' = f z (UnsafeRange wL k') x + + in f z' (UnsafeRange k wR) c + + + +-- | \(\mathcal{O}(n)\). +-- Fold right-to-left over the ranges. +foldr' :: (Range -> Color -> a -> a) -> a -> Zebra -> a +foldr' f = \ !z t -> + case t of + Bin _ l r -> let !(# w', x', z' #) = foldr'_R maxBound f z r + in foldr'_L 0 f w' x' z' l + + Bla k -> goTip z k Black + Whi k -> goTip z k White + Nil _ -> z + where + goTip z k c + | k == 0 = f (UnsafeRange 0 maxBound) c z + + | otherwise = let !k' = k - 1 + + !(# x #) = invert c + + in f (UnsafeRange 0 k') x $! f (UnsafeRange k maxBound) c z + +foldr'_R :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> (# Word, Color, a #) +foldr'_R !wR f = go + where + go !z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = go z r + in foldr'_M f w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# 0, Black, z #) + where + goTip k c = let !k' = k - 1 + in (# k', c, f (UnsafeRange k wR) c z #) + +foldr'_L :: Word -> (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> a +foldr'_L !wL f = go + where + go !w !x !z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = foldr'_M f w x z r + in go w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | k == 0 = f (UnsafeRange wL w) c z + + | otherwise = let !k' = k - 1 + in f (UnsafeRange wL k') x $! f (UnsafeRange k w) c z + +foldr'_M + :: (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> (# Word, Color, a #) +foldr'_M f = go + where + go w x !z t = + case t of + Bin _ l r -> let !(# w', x', z' #) = go w x z r + in go w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# w, x, z #) + where + goTip k c = let !k' = k - 1 + in (# k', c, f (UnsafeRange k w) c z #) + + + +-- | \(\mathcal{O}(n)\). +-- Fold right-to-left over the ranges of all the keys greater than +-- or equal to the given one. +foldrR' :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrR' wL = foldrR'_ wL maxBound + +foldrR'_ :: Word -> Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrR'_ !wL !wR f = go + where + go !z t = + case t of + Bin p l r -> + if wL < p + then let !(# w', x', z' #) = foldr'_R wR f z r + in foldrR'_L wL f w' x' z' l + + else go z r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | k == 0 = f (UnsafeRange wL wR) c z + + | wL < k = let !k' = k - 1 + + !(# x #) = invert c + + in f (UnsafeRange wL k') x $! f (UnsafeRange k wR) c z + + | otherwise = f (UnsafeRange wL wR) c z + +foldrR'_L :: Word -> (Range -> Color -> a -> a) -> Word -> Color -> a -> Zebra -> a +foldrR'_L !wL f = go + where + go !w !x !z t = + case t of + Bin p l r -> + if wL < p + then let !(# w', x', z' #) = foldr'_M f w x z r + in go w' x' z' l + + else go w x z r + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | wL < k = let !k' = k - 1 + in f (UnsafeRange wL k') x $! f (UnsafeRange k w) c z + + | otherwise = f (UnsafeRange wL w) c z + + + +-- | \(\mathcal{O}(n)\). +-- Fold right-to-left over the ranges of all the keys smaller than +-- or equal to the given one. +foldrL' :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrL' = foldrL'_ 0 + +foldrL'_ :: Word -> Word -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrL'_ !wL !wR f = go + where + go !z t = + case t of + Bin p l r -> + if wR < p + then go z l + else let !(# w', x', z' #) = foldrL'_R wR f z r + in foldr'_L wL f w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> z + where + goTip k c + | k == 0 = f (UnsafeRange wL wR) c z + + | wR >= k = let !k' = k - 1 + + !(# x #) = invert c + + in f (UnsafeRange wL k') x $! f (UnsafeRange k wR) c z + + | otherwise = let !(# x #) = invert c + in f (UnsafeRange wL wR) x z + +foldrL'_R :: Word -> (Range -> Color -> a -> a) -> a -> Zebra -> (# Word, Color, a #) +foldrL'_R !wR f = go + where + go !z t = + case t of + Bin p l r -> + if wR < p + then go z l + else let !(# w', x', z' #) = go z r + in foldr'_M f w' x' z' l + + Bla k -> goTip k Black + Whi k -> goTip k White + Nil _ -> (# 0, Black, z #) + where + goTip k c + | wR >= k = let !k' = k - 1 + in (# k', c, f (UnsafeRange k wR) c z #) + + | otherwise = (# wR, c, z #) + + + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Fold right-to-left with a strict accumulator over the ranges of all the keys +-- in the given range. +foldrRange' :: Range -> (Range -> Color -> a -> a) -> a -> Zebra -> a +foldrRange' (UnsafeRange wL wR) f !z + | wL == wR = \t -> let !c = Data.Zebra.Word.Internal.lookup wL t + in f (UnsafeRange wL wR) c z + + | otherwise = unsafeFoldrRange' wL wR f z + +-- | \(\mathcal{O}(\min(n,W) + n_I)\). +-- Fold right-to-left with a strict accumulator over the ranges of all the keys +-- in the \([k_L, k_R)\) interval. +-- +-- \(k_R\) __must__ be greater than \(k_L\). +unsafeFoldrRange' + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> (Range -> Color -> a -> a) + -> a + -> Zebra + -> a +unsafeFoldrRange' !wL !wR f = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + go !z t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> let !(# w', x', z' #) = foldrL'_R wR f z r + in foldrR'_L wL f w' x' z' l + + LT | pM <= upper p -> go z r + | p >= lower pM -> if wL < p + then let !(# w', x', z' #) = foldrL'_R wR f z r + in foldr'_L wL f w' x' z' l + + else foldrR'_ wL wR f z r + + | otherwise -> let !(# cR #) = colorR r + in f (UnsafeRange wL wR) cR z + + GT | p <= upper pM -> if wR >= p + then let !(# w', x', z' #) = foldr'_R wR f z r + in foldrR'_L wL f w' x' z' l + + else foldrL'_ wL wR f z l + + | pM >= lower p -> go z l + + | otherwise -> let !(# cR #) = colorL l + !(# cL #) = invert cR + + in f (UnsafeRange wL wR) cL z + + Bla k -> tipM k Black + Whi k -> tipM k White + Nil _ -> z + where + tipM k c + | wL >= k = f (UnsafeRange wL wR) c z + | otherwise = + let !(# x #) = invert c + in if wR < k + then f (UnsafeRange wL wR) x z + else let !k' = k - 1 + in f (UnsafeRange wL k') x $! f (UnsafeRange k wR) c z + + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the color of the key. +lookup :: Word -> Zebra -> Color +lookup !w = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go l + else let !(# cR #) = colorL l + !(# cL #) = invert cR + in cL + + else if w <= upper p + then go r + else let !(# cR #) = colorR r + in cR + + Bla k -> goTip k Black + Whi k -> goTip k White + + Nil _ -> Black + + goTip k c + | w < k = let !(# cL #) = invert c + in cL + | otherwise = c + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the key of the given color that is smaller than or equal to the given key. +lookupL :: Color -> Word -> Zebra -> Maybe Word +lookupL !x !w = go (Nil Black) + where + go !v t = + case t of + Bin p l r + | w < p -> go v l + | otherwise -> go l r + + Bla k -> goTip Black k v + Whi k -> goTip White k v + + Nil _ -> Nothing + + goTip c k v = + case w >= k of + True + | k == 0 -> if c == x + then Just w + else Nothing + + | otherwise -> Just $! if c == x + then w + else k - 1 + False + | c == x -> case v of + Nil _ -> Nothing + _ -> let !(# kL #) = keyR v + in Just $! kL - 1 + + | otherwise -> Just w + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the key of the given color that is smaller than or equal to the given key, +-- falling back to the default value if no such key exists. +findL + :: Word -- ^ Default value + -> Color + -> Word -- ^ Key + -> Zebra + -> Word +findL d !x !w = go (Nil Black) + where + go !v t = + case t of + Bin p l r + | w < p -> go v l + | otherwise -> go l r + + Bla k -> goTip Black k v + Whi k -> goTip White k v + + Nil _ -> d + + goTip c k v = + case w >= k of + True + | k == 0 -> if c == x + then w + else d + + | c == x -> w + | otherwise -> k - 1 + + False + | c == x -> case v of + Nil _ -> d + _ -> let !(# kL #) = keyR v + in kL - 1 + | otherwise -> w + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the key of the given color that is greater than or equal to the given key. +lookupR :: Color -> Word -> Zebra -> Maybe Word +lookupR !x !w = go (Nil Black) + where + go !v t = + case t of + Bin p l r + | w < p -> go r l + | otherwise -> go v r + + Bla k -> goTip Black k v + Whi k -> goTip White k v + + Nil _ -> Nothing + + goTip c k v = + case w < k of + True -> Just $! if c == x + then k + else w + False + | c == x -> Just w + | otherwise -> case v of + Nil _ -> Nothing + _ -> let !(# kR #) = keyL v + in Just kR + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Look up the key of the given color that is greater than or equal to the given key, +-- falling back to the default value if no such key exists. +findR + :: Word -- ^ Default value + -> Color + -> Word -- ^ Key + -> Zebra + -> Word +findR d !x !w = go (Nil Black) + where + go !v t = + case t of + Bin p l r + | w < p -> go r l + | otherwise -> go v r + + Bla k -> goTip Black k v + Whi k -> goTip White k v + + Nil _ -> d + + goTip c k v = + case w < k of + True + | c == x -> k + | otherwise -> w + + False + | c == x -> w + | otherwise -> case v of + Nil _ -> d + _ -> let !(# kR #) = keyL v + in kR + + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Set every key smaller than or equal to the given one to the given color. +fillL :: Word -> Color -> Zebra -> Zebra +fillL w x + | w == maxBound = \_ -> Mono x + | otherwise = unsafeFillL (w + 1) x + +-- | \(\mathcal{O}(\min(n,W))\). +-- Set every key smaller than the given one to the given color. +-- +-- The given key __must not__ be @0@. +unsafeFillL :: Word -> Color -> Zebra -> Zebra +unsafeFillL w x = \t -> + case fillL_ w x t of + Nil _ -> Mono x + t' -> t' + +fillL_ :: Word -> Color -> Zebra -> Zebra +fillL_ !w !x = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then rebinL p (go l) r + else let !(# cR #) = colorL l + in if cR == x + then let !(# cL #) = invert cR + in join w (tip w cL) p t + else t + + else if w <= upper p + then go r + else let !(# cR #) = colorR r + in if cR == x + then Nil Black + else tip w cR + + Bla k -> goTip Black k t + Whi k -> goTip White k t + + Nil _ -> t + + goTip c k t + | w >= k = if c == x + then Nil Black + else if w == k + then t + else tip w c + + | otherwise = if c == x + then let !(# cL #) = invert x + in join w (tip w cL) k t + else t + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Set every key greater than or equal to the given one to the given color. +fillR :: Word -> Color -> Zebra -> Zebra +fillR w x = \t -> + case fillR_ w x t of + Nil _ -> Mono x + t' -> t' + +fillR_ :: Word -> Color -> Zebra -> Zebra +fillR_ !w !x = go + where + go t = + case t of + Bin p l r -> + if w < p + then if w >= lower p + then go l + else let !(# cR #) = colorL l + in if cR == x + then tip w x + else Nil Black + + else if w <= upper p + then rebinR p l (go r) + else let !(# cR #) = colorR r + in if cR == x + then t + else join w (tip w x) p t + + Bla k -> goTip Black k t + Whi k -> goTip White k t + + Nil _ -> t + + goTip c k t + | w <= k = if c == x + then if w == k + then t + else tip w c + + else Nil Black + + | otherwise = if c == x + then t + else if k == 0 + then tip w x + else join w (tip w x) k t + + + +-- | \(\mathcal{O}(\min(n,W))\). +-- Set every key in the range to the given color. +fillRange :: Range -> Color -> Zebra -> Zebra +fillRange (UnsafeRange wL wR) x + | wL == 0 = fillL wR x + | wR == maxBound = fillR wL x + | otherwise = unsafeFillRange wL (wR + 1) x + +-- | \(\mathcal{O}(\min(n,W) + n_L)\). +-- Set every key in the \([k_L, k_R)\) interval to the given color. +-- +-- \(k_L\) __must not__ be @0@. \(k_R\) __must__ be greater than \(k_L\). +unsafeFillRange + :: Word -- ^ \(k_L\) + -> Word -- ^ \(k_R\) + -> Color + -> Zebra + -> Zebra +unsafeFillRange wL wR x t = + case fillRange_ x wL wR t of + Nil _ -> Mono x + t' -> t' + +fillRange_ :: Color -> Word -> Word -> Zebra -> Zebra +fillRange_ !x !wL !wR = go + where + !mM = branchingBit wL wR + + !pM = mask wL mM .|. mM + + binM = let !(# c #) = invert x + in Bin pM (tip wL x) (tip wR c) + + go t = + case t of + Bin p l r -> + case Prelude.compare p pM of + EQ -> rebin p (fillR_ wL x l) (fillL_ wR x r) + + LT | pM <= upper p -> rebinR p l (go r) + | p >= lower pM -> let l' = if wL < p + then fillR_ wL x l + else rebinR p l (fillR_ wL x r) + + !(# cR #) = colorR r + + in if cR == x + then l' + else join p l' pM (tip wR cR) + + | otherwise -> + let !(# cR #) = colorR r + in if cR == x + then t + else join p t pM binM + + GT | p <= upper pM -> let r' = if wR >= p + then fillL_ wR x r + else rebinL p (fillL_ wR x l) r + + !(# cR #) = colorL l + + in if cR == x + then join pM (tip wL x) p r' + else r' + + | pM >= lower p -> rebinL p (go l) r + | otherwise -> + let !(# cR #) = colorL l + in if cR == x + then join p t pM binM + else t + + Bla k -> goTip k Black t + Whi k -> goTip k White t + + Nil _ -> t + + goTip k c t + | wR < k = if c == x + then join k t pM binM + else t + + | k < wL = if c == x + then t + else if k == 0 + then binM + else join k t pM binM + + | c == x = tip wL c + | otherwise = tip wR c + + + +colorL :: Zebra -> (# Color #) +colorL t = + case t of + Bin _ l _ -> colorL l + Bla _ -> (# Black #) + _ -> (# White #) + +colorR :: Zebra -> (# Color #) +colorR t = + case t of + Bin _ _ r -> colorR r + Bla _ -> (# Black #) + _ -> (# White #) + + +keyL :: Zebra -> (# Word #) +keyL t = + case t of + Bin _ l _ -> keyL l + Bla k -> (# k #) + Whi k -> (# k #) + Nil _ -> (# 0 #) + +keyR :: Zebra -> (# Word #) +keyR t = + case t of + Bin _ _ r -> keyR r + Bla k -> (# k #) + Whi k -> (# k #) + Nil _ -> (# 0 #) + + + +-- | \(\mathcal{O}(n)\). +-- Invert the colors of all keys. +complement :: Zebra -> Zebra +complement t = + case t of + Bin p l r -> Bin p (Data.Zebra.Word.Internal.complement l) + (Data.Zebra.Word.Internal.complement r) + Bla k -> Whi k + Whi k -> Bla k + Nil _ -> t + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Union of two trees over the given color. +union :: Color -> Zebra -> Zebra -> Zebra +union x l r = + case l of + Mono c | c == x -> l + | otherwise -> r + + _ -> + case r of + Mono c | c == x -> r + | otherwise -> l + + _ -> + case anyAny l r of + Nil _ -> Mono x + t -> t + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Bla kA -> tipAny (# kA, Black #) tA tB + Whi kA -> tipAny (# kA, White #) tA tB + + Nil _ -> tA + + tipAny uA@(# kA, cA #) tA tB = + case tB of + Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) tB + + Bla kB -> goTip kB Black + Whi kB -> goTip kB White + + Nil _ -> tB + where + goTip kB cB + | cA == cB = if (cA == x) == (kA < kB) + then tA + else tB + + | otherwise = if kA == kB || ((cA == x) == (kA < kB)) + then Nil Black + else join kA tA kB tB + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Bla kB -> tipBin (# kB, Black #) tB uA tA + Whi kB -> tipBin (# kB, White #) tB uA tA + + Nil _ -> tB + + tipBin uA@(# kA, cA #) tA (# pB, lB, rB #) tB = + if kA < pB + then if kA >= lower pB + then if cA == x + then tipAny uA tA lB + else rebinL pB (tipAny uA tA lB) rB + + else let !(# cB #) = colorL lB + in if cA == cB + then if cA == x + then tA + else tB + + else if cA == x + then Nil Black + else join kA tA pB tB + + else if kA <= upper pB + then if cA == x + then rebinR pB lB (tipAny uA tA rB) + else tipAny uA tA rB + + else let !(# cB #) = colorR rB + in if cA == cB + then if cA == x + then tB + else tA + + else if cA == x + then join kA tA pB tB + else Nil Black + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> let !(# cR #) = colorL lB + in if cR == x + then rebinR pA lA (binAny uB tB rA) + else binAny uB tB rA + + | pA >= lower pB -> let !(# cL #) = colorR rA + in if cL == x + then binAny uA tA lB + else rebinL pB (binAny uA tA lB) rB + + | otherwise -> + let !(# cA #) = colorR rA + !(# cB #) = colorL lB + + in if cA == cB + then if cA == x + then tA + else tB + + else if cA == x + then Nil Black + else join pA tA pB tB + + GT | pA <= upper pB -> let !(# cR #) = colorL lA + in if cR == x + then rebinR pB lB (binAny uA tA rB) + else binAny uA tA rB + + | pB >= lower pA -> let !(# cL #) = colorR rB + in if cL == x + then binAny uB tB lA + else rebinL pA (binAny uB tB lA) rA + + | otherwise -> + let !(# cB #) = colorR rB + !(# cA #) = colorL lA + + in if cA == cB + then if cA == x + then tB + else tA + + else if cA == x + then join pA tA pB tB + else Nil Black + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Intersection of two trees over the given color. +intersection :: Color -> Zebra -> Zebra -> Zebra +intersection x = + let !(# c #) = invert x + in union c + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Determine whether two trees are disjoint over the given color. +disjoint :: Color -> Zebra -> Zebra -> Bool +disjoint x l r = + case l of + Mono c -> c /= x + _ -> + case r of + Mono c -> c /= x + _ -> anyAny l r + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Bla kA -> tipAny (# kA, Black #) tA tB + Whi kA -> tipAny (# kA, White #) tA tB + + Nil _ -> False + + tipAny uA@(# kA, cA #) tA tB = + case tB of + Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) + + Bla kB -> goTip kB Black + Whi kB -> goTip kB White + + Nil _ -> False + where + goTip kB cB + | cA == cB = False + | otherwise = kA == kB || ((cA == x) == (kA < kB)) + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Bla kB -> tipBin (# kB, Black #) tB uA + Whi kB -> tipBin (# kB, White #) tB uA + + Nil _ -> False + + tipBin uA@(# kA, cA #) tA (# pB, lB, rB #) = + if kA < pB + then if kA >= lower pB + then cA == x && tipAny uA tA lB + + else let !(# cB #) = colorL lB + in cA /= cB && cA == x + + else if kA <= upper pB + then cA /= x && tipAny uA tA rB + + else let !(# cB #) = colorR rB + in cA /= cB && cB == x + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> anyAny lA lB && anyAny rA rB + + LT | pB <= upper pA -> let !(# cR #) = colorL lB + in cR /= x && binAny uB tB rA + + | pA >= lower pB -> let !(# cL #) = colorR rA + in cL == x && binAny uA tA lB + + | otherwise -> + let !(# cA #) = colorR rA + !(# cB #) = colorL lB + + in cA /= cB && cA == x + + GT | pA <= upper pB -> let !(# cR #) = colorL lA + in cR /= x && binAny uA tA rB + + | pB >= lower pA -> let !(# cL #) = colorR rB + in cL == x && binAny uB tB lA + + | otherwise -> + let !(# cB #) = colorR rB + !(# cA #) = colorL lA + + in cA /= cB && cB == x + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Difference of two trees over the given color. +difference :: Color -> Zebra -> Zebra -> Zebra +difference x l r = + case l of + Mono c | c == x -> Data.Zebra.Word.Internal.complement r + | otherwise -> l + + _ -> + case r of + Mono c | c == x -> let !(# x' #) = invert x + in Mono x' + + | otherwise -> l + + _ -> + case anyAny L l r of + Nil _ -> let !(# c #) = invert x + in Mono c + + t -> t + where + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Bla kA -> tipAny s (# kA, Black #) tA tB + Whi kA -> tipAny s (# kA, White #) tA tB + + Nil _ -> tA + + tipAny s uA@(# kA, cA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) tB + + Bla kB -> goTip kB Black + Whi kB -> goTip kB White + + Nil _ -> tB + where + goTip kB cB = + case s of + L -> goTipL kA cA tA kB cB + R -> goTipL kB cB tB kA cA + + goTipL kL cL tL kR cR = + case Prelude.compare kL kR of + EQ -> if cL == cR + then Nil Black + else tL + + LT -> if cL == cR + then if cL == x + then let !(# c #) = invert x + in join kL tL kR (tip kR c) + + else Nil Black + + else if cL == x + then tip kR x + else tL + + GT -> if cL == cR + then if cL == x + then Nil Black + else join kL tL kR (tip kR x) + + else if cL == x + then tL + else tip kR cL + + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Bla kB -> goTip kB Black + Whi kB -> goTip kB White + + Nil _ -> tB + where + goTip kB cB = + let !(# s' #) = other s + in tipBin s' (# kB, cB #) tB uA tA + + tipBin s uA@(# kA, cA #) tA (# pB, lB, rB #) tB = + case s of + L -> if kA < pB + then if kA >= lower pB + then if cA == x + then rebinL pB (tipAny s uA tA lB) + (Data.Zebra.Word.Internal.complement rB) + + else tipAny s uA tA lB + + else let !(# cR #) = colorL lB + in if cA == cR + then if cA == x + then join kA tA + pB $ Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + + else Nil Black + + else if cA == x + then Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + + else tA + + else if kA <= upper pB + then if cA == x + then tipAny s uA tA rB + else rebinR pB (Data.Zebra.Word.Internal.complement lB) + (tipAny s uA tA rB) + + else let !(# cL #) = colorR rB + in if cA == cL + then if cA == x + then Nil Black + else join kA tA + pB $ Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + + else if cA == x + then tA + else Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + + R -> if kA < pB + then if kA >= lower pB + then if cA == x + then tipAny s uA tA lB + else rebinL pB (tipAny s uA tA lB) rB + + else let !(# cR #) = colorL lB + in if cA == cR + then if cA == x + then Nil Black + else join kA (tip kA x) pB tB + + else if cA == x + then tip kA cR + else tB + + else if kA <= upper pB + then if cA == x + then rebinR pB lB (tipAny s uA tA rB) + else tipAny s uA tA rB + + else let !(# cL #) = colorR rB + in if cA == cL + then if cA == x + then let !(# c #) = invert x + in join kA (tip kA c) pB tB + else Nil Black + + else if cA == x + then tB + else tip kA cL + + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pB (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + + !(# cR #) = colorL lB + + in case s of + L -> if cR == x + then rebinR pA lA (binAny s' uB tB rA) + else binAny s' uB tB rA + + R -> if cR == x + then binAny s' uB tB rA + else rebinR pA (Data.Zebra.Word.Internal.complement lA) + (binAny s' uB tB rA) + + | pA >= lower pB -> let !(# cL #) = colorR rA + in case s of + L -> if cL == x + then rebinL pB (binAny s uA tA lB) + (Data.Zebra.Word.Internal.complement rB) + else binAny s uA tA lB + + R -> if cL == x + then binAny s uA tA lB + else rebinL pB (binAny s uA tA lB) rB + + | otherwise -> + let !(# cA #) = colorR rA + !(# cB #) = colorL lB + + in case s of + L -> if cA == cB + then if cA == x + then join pA tA + pB $ Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + else Nil Black + + else if cA == x + then Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + else tA + + R -> if cA == cB + then if cA == x + then Nil Black + else join pB tB + pA $ Bin pA (Data.Zebra.Word.Internal.complement lA) + (Data.Zebra.Word.Internal.complement rA) + + else if cA == x + then Bin pA (Data.Zebra.Word.Internal.complement lA) + (Data.Zebra.Word.Internal.complement rA) + else tB + + GT | pA <= upper pB -> let !(# cR #) = colorL lA + in case s of + L -> if cR == x + then binAny s uA tA rB + else rebinR pB + (Data.Zebra.Word.Internal.complement lB) + (binAny s uA tA rB) + + R -> if cR == x + then rebinR pB lB (binAny s uA tA rB) + else binAny s uA tA rB + + | pB >= lower pA -> let !(# s' #) = other s + + !(# cL #) = colorR rB + + in case s of + L -> if cL == x + then binAny s' uB tB lA + else rebinL pA (binAny s' uB tB lA) rA + + R -> if cL == x + then rebinL pA (binAny s' uB tB lA) + (Data.Zebra.Word.Internal.complement rA) + + else binAny s' uB tB lA + + | otherwise -> + let !(# cB #) = colorR rB + !(# cA #) = colorL lA + + in case s of + L -> if cA == cB + then if cA == x + then Nil Black + else join pA tA + pB $ Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + + else if cA == x + then tA + else Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + + R -> if cA == cB + then if cA == x + then join pB tB + pA $ Bin pA (Data.Zebra.Word.Internal.complement lA) + (Data.Zebra.Word.Internal.complement rA) + else Nil Black + + else if cA == x + then tB + else Bin pA (Data.Zebra.Word.Internal.complement lA) + (Data.Zebra.Word.Internal.complement rA) + + + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Symmetric difference of two trees over the given color. +symmetricDifference :: Color -> Zebra -> Zebra -> Zebra +symmetricDifference xFG l r = + case l of + Mono c | c == xFG -> Data.Zebra.Word.Internal.complement r + | otherwise -> r + + _ -> + case r of + Mono c | c == xFG -> Data.Zebra.Word.Internal.complement l + | otherwise -> l + + _ -> + case anyAny l r of + Nil c -> Mono c + t -> t + where + anyAny tA tB = + case tA of + Bin pA lA rA -> binAny (# pA, lA, rA #) tA tB + + Bla kA -> tipAny (# kA, Black #) tA tB + Whi kA -> tipAny (# kA, White #) tA tB + + Nil _ -> tA + + tipAny uA@(# kA, cA #) tA tB = + case tB of + Bin pB lB rB -> tipBin uA tA (# pB, lB, rB #) tB + + Bla kB -> goTip kB Black + Whi kB -> goTip kB White + + Nil _ -> tB + where + goTip kB cB + | kA == kB = Nil $ if cA == cB + then let !(# xBG #) = invert xFG + in xBG + else xFG + + | otherwise = let nA | (cB == xFG) == (kA < kB) = tA + | otherwise = let !(# c #) = invert cA + in tip kA c + + nB | (cA == xFG) == (kA < kB) = let !(# c #) = invert cB + in tip kB c + | otherwise = tB + + in join kA nA kB nB + + binAny uA tA tB = + case tB of + Bin pB lB rB -> binBin uA tA (# pB, lB, rB #) tB + + Bla kB -> tipBin (# kB, Black #) tB uA tA + Whi kB -> tipBin (# kB, White #) tB uA tA + + Nil _ -> tB + + tipBin uA@(# kA, cA #) tA (# pB, lB, rB #) tB = + if kA < pB + then if kA >= lower pB + then let r' | cA == xFG = Data.Zebra.Word.Internal.complement rB + | otherwise = rB + + in rebinL pB (tipAny uA tA lB) r' + + else let !(# cL #) = colorL lB + + nA | cL == xFG = tA + | otherwise = let !(# c #) = invert cA + in tip kA c + + nB | cA == xFG = Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + | otherwise = tB + + in join kA nA pB nB + + else if kA <= upper pB + then let l' | cA == xFG = lB + | otherwise = Data.Zebra.Word.Internal.complement lB + + in rebinR pB l' (tipAny uA tA rB) + + else let !(# cR #) = colorR rB + + nA | cR == xFG = let !(# c #) = invert cA + in tip kA c + | otherwise = tA + + nB | cA == xFG = tB + | otherwise = Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + + in join kA nA pB nB + + binBin uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> rebin pA (anyAny lA lB) (anyAny rA rB) + + LT | pB <= upper pA -> let !(# cR #) = colorL lB + + l' | cR == xFG = lA + | otherwise = Data.Zebra.Word.Internal.complement lA + + in rebinR pA l' (binAny uB tB rA) + + | pA >= lower pB -> let !(# cL #) = colorR rA + + r' | cL == xFG = Data.Zebra.Word.Internal.complement rB + | otherwise = rB + + in rebinL pB (binAny uA tA lB) r' + + | otherwise -> + let !(# cA #) = colorR rA + !(# cB #) = colorL lB + + nA | cB == xFG = tA + | otherwise = Bin pA (Data.Zebra.Word.Internal.complement lA) + (Data.Zebra.Word.Internal.complement rA) + + nB | cA == xFG = Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + | otherwise = tB + + in join pA nA pB nB + + GT | pA <= upper pB -> let !(# cR #) = colorL lA + + l' | cR == xFG = lB + | otherwise = Data.Zebra.Word.Internal.complement lB + + in rebinR pB l' (binAny uA tA rB) + + | pB >= lower pA -> let !(# cL #) = colorR rB + + r' | cL == xFG = Data.Zebra.Word.Internal.complement rA + | otherwise = rA + + in rebinL pA (binAny uB tB lA) r' + + | otherwise -> + let !(# cB #) = colorR rB + !(# cA #) = colorL lA + + nA | cB == xFG = Bin pA (Data.Zebra.Word.Internal.complement lA) + (Data.Zebra.Word.Internal.complement rA) + | otherwise = tA + + nB | cA == xFG = tB + | otherwise = Bin pB (Data.Zebra.Word.Internal.complement lB) + (Data.Zebra.Word.Internal.complement rB) + in join pA nA pB nB + + + +data S = L | R + deriving Show + +other :: S -> (# S #) +other L = (# R #) +other R = (# L #) + +-- | \(\mathcal{O}(n_A + n_B)\). +-- Compare two trees with respect to set inclusion over the given color. +compare :: Color -> Zebra -> Zebra -> PartialOrdering +compare x l r = + case l of + Mono cA -> + case r of + Mono cB | cA == cB -> Equal + | cA == x -> Superset + | otherwise -> Subset + + _ | cA == x -> Superset + | otherwise -> Subset + _ -> + case r of + Mono cB | cB == x -> Subset + | otherwise -> Superset + + _ -> anyAny L l r + where + anyAny s tA tB = + case tA of + Bin pA lA rA -> binAny s (# pA, lA, rA #) tA tB + + Bla kA -> tipAny s (# kA, Black #) tA tB + Whi kA -> tipAny s (# kA, White #) tA tB + + Nil _ -> Incomparable + + tipAny s uA@(# kA, cA #) tA tB = + case tB of + Bin pB lB rB -> tipBin s uA tA (# pB, lB, rB #) + + Bla kB -> goTip kB Black + Whi kB -> goTip kB White + + Nil _ -> Incomparable + where + goTip kB cB + | cA == cB = if kA == kB + then Equal + else if (cA == x) == (kA < kB) + then case s of + L -> Superset + R -> Subset + + else case s of + L -> Subset + R -> Superset + + | otherwise = Incomparable + + binAny s uA tA tB = + case tB of + Bin pB lB rB -> binBin s uA tA (# pB, lB, rB #) tB + + Bla kB -> goTip kB Black + Whi kB -> goTip kB White + + Nil _ -> Incomparable + where + goTip kB cB = let !(# s' #) = other s + in tipBin s' (# kB, cB #) tB uA + + tipBin s uA@(# kA, cA #) tA (# pB, lB, rB #) = + if kA < pB + then if kA >= lower pB + then let !(# o #) = if cA == x + then case s of + L -> (# Superset #) + R -> (# Subset #) + + else case s of + L -> (# Subset #) + R -> (# Superset #) + + in order o (tipAny s uA tA lB) + + else let !(# cR #) = colorL lB + in if cA == cR + then if cA == x + then case s of + L -> Superset + R -> Subset + + else case s of + L -> Subset + R -> Superset + + else Incomparable + + else if kA <= upper pB + then let !(# o #) = if cA == x + then case s of + L -> (# Subset #) + R -> (# Superset #) + + else case s of + L -> (# Superset #) + R -> (# Subset #) + + in order o (tipAny s uA tA rB) + + else let !(# cL #) = colorR rB + in if cA == cL + then if cA == x + then case s of + L -> Subset + R -> Superset + + else case s of + L -> Superset + R -> Subset + + else Incomparable + + binBin s uA@(# pA, lA, rA #) tA uB@(# pB, lB, rB #) tB = + case Prelude.compare pA pB of + EQ -> order (anyAny s lA lB) (anyAny s rA rB) + + LT | pB <= upper pA -> let !(# s' #) = other s + + !(# cR #) = colorL lB + + !(# o #) = if cR == x + then case s of + L -> (# Superset #) + R -> (# Subset #) + + else case s of + L -> (# Subset #) + R -> (# Superset #) + + in order o (binAny s' uB tB rA) + + | pA >= lower pB -> let !(# cL #) = colorR rA + + !(# o #) = if cL == x + then case s of + L -> (# Superset #) + R -> (# Subset #) + + else case s of + L -> (# Subset #) + R -> (# Superset #) + + in order o (binAny s uA tA lB) + + | otherwise -> let !(# cL #) = colorR rA + !(# cR #) = colorL lB + + in if cL == cR + then if cL == x + then case s of + L -> Superset + R -> Subset + + else case s of + L -> Subset + R -> Superset + + else Incomparable + + GT | pA <= upper pB -> let !(# cR #) = colorL lA + + !(# o #) = if cR == x + then case s of + L -> (# Subset #) + R -> (# Superset #) + + else case s of + L -> (# Superset #) + R -> (# Subset #) + + in order o (binAny s uA tA rB) + + | pB >= lower pA -> let !(# s' #) = other s + + !(# cL #) = colorR rB + + !(# o #) = if cL == x + then case s of + L -> (# Subset #) + R -> (# Superset #) + + else case s of + L -> (# Superset #) + R -> (# Subset #) + + in order o (binAny s' uB tB lA) + + | otherwise -> let !(# cL #) = colorR rB + !(# cR #) = colorL lA + + in if cL == cR + then if cL == x + then case s of + L -> Subset + R -> Superset + + else case s of + L -> Superset + R -> Subset + + else Incomparable diff --git a/src/Data/Zebra/Word/Unsafe.hs b/src/Data/Zebra/Word/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Zebra/Word/Unsafe.hs @@ -0,0 +1,76 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| + Data structure internals, helper operations and unsafe functions. + + == Implementation + + The tree is structurally identical to the + 'Data.Patricia.Word.Strict.Unsafe.Patricia' tree, holding 'Color's as values. + + A key \(k\) in the tree denotes a right-open interval + \([k, k_R)\) within which every key has the same color as \(k\). \(k_R\) is the key + immediately to the right of \(k\), or, if \(k\) is the rightmost key, \(+\infty\). + + Two adjacent intervals __must not__ have the same color. This both removes + redundancies and allows to make assumptions about the color of the key + immediately to the left. + + The following is a visual example of a possible 4-bit tree under these rules: + + ![4-bit tree](https://raw.githubusercontent.com/sergv/radix-tree/master/images/4bit.svg) + -} + +module Data.Zebra.Word.Unsafe + ( Zebra (..) + , Color (..) + + -- * Bit operations + , Prefix + , Key + + -- | === Compare + , beyond + , upper + , lower + + -- | === Create + , Mask + , zeroBit + , mask + , branchingBit + + -- * Directional + -- ** Size + , unsafeSizeL + , unsafeSizeR + + -- ** Insert + , unsafeFillL + + -- * Range + , Range (..) + + -- ** Size + , unsafeMonoRange + , unsafeSizeRange + + -- ** Insert + , unsafeFillRange + + -- ** Fold + -- | === Left-to-right + , unsafeFoldlRange + , unsafeFoldlRange' + + -- | === Right-to-left + , unsafeFoldrRange + , unsafeFoldrRange' + + -- * Full tree + -- ** Size + , unsafeSize + ) where + +import Data.Zebra.Word.Internal +import Radix.Word.Foundation diff --git a/src/Numeric/Long.hs b/src/Numeric/Long.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Long.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Numeric.Long + ( showLongHex + , showLongBin + , showPrefix + ) where + +import Data.Bits +import Data.Char + + + +showLongHex :: (FiniteBits a, Integral a, Num a) => a -> ShowS +showLongHex (w0 :: a) = go w0 0 + where + go w n + | n >= finiteBitSize (0 :: a) = id + | otherwise = + let (q, r) = quotRem w 16 + in go q (n + 4 :: Int) . showChar (intToDigit (fromIntegral r)) + + + +showLongBin :: (FiniteBits a, Integral a, Num a) => a -> ShowS +showLongBin (w :: a) = go 0 + where + go n + | n >= finiteBitSize (0 :: a) = id + | otherwise = + go (n + 1) . showChar (chr . fromIntegral $ 48 + (unsafeShiftR w n .&. 1)) + + + +showPrefix :: (FiniteBits a, Integral a, Num a) => a -> ShowS +showPrefix (w :: a) = go 0 + where + m = w .&. negate w + + go n + | n >= finiteBitSize (0 :: a) = id + | otherwise = + go (n + 1) . showChar + ( if unsafeShiftL 1 n >= m + then chr . fromIntegral $ 48 + (unsafeShiftR w n .&. 1) + else 'X' + ) diff --git a/src/Radix/Common.hs b/src/Radix/Common.hs new file mode 100644 --- /dev/null +++ b/src/Radix/Common.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE GADTs + , UnboxedTuples #-} + +module Radix.Common + ( PartialOrdering (..) + , order + + , S (..) + , other + , limit + ) where + + + +-- | Comparison of two sets, \(A\) and \(B\) respectively. +data PartialOrdering = Subset -- ^ \(A \subset B\). + | Superset -- ^ \(A \supset B\). + | Equal -- ^ \(A = B\). + | Incomparable -- ^ \(A \parallel B\). + deriving (Show, Eq) + +-- | Comparison of two partial orderings. +order :: PartialOrdering -> PartialOrdering -> PartialOrdering +order Subset Subset = Subset +order Subset Equal = Subset + +order Superset Superset = Superset +order Superset Equal = Superset + +order Equal o = o + +order _ _ = Incomparable + + + +-- | Merge side. +data S a b x y where + L :: S x y x y + R :: S y x x y + +-- | The other merge side. +other :: S a b x y -> (# S b a x y #) +other L = (# R #) +other R = (# L #) + +-- | Limits the left side to a 'Subset'. +limit :: S x y a b -> PartialOrdering -> PartialOrdering +limit L Superset = Incomparable +limit R Subset = Incomparable +limit s Equal = case s of + L -> Subset + R -> Superset +limit _ o = o diff --git a/src/Radix/Exception.hs b/src/Radix/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Radix/Exception.hs @@ -0,0 +1,21 @@ +module Radix.Exception + ( MalformedTree (..) + ) where + +import Control.Exception + + + +-- | Exception thrown by functions that need to return a value, +-- but instead find an invariant-breaking empty node. +data MalformedTree = MalformedTree + String -- ^ Module name + String -- ^ Function name + +instance Show MalformedTree where + showsPrec _ (MalformedTree loc fun) = + showString "radix-tree#" + . showString loc . showChar '.' + . showString fun . showString ": Encountered Nil, tree is malformed" + +instance Exception MalformedTree diff --git a/src/Radix/Word/Common.hs b/src/Radix/Word/Common.hs new file mode 100644 --- /dev/null +++ b/src/Radix/Word/Common.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Radix.Word.Common + ( Range (Range, ..) + ) where + +import Radix.Word.Foundation + + + +-- | A closed interval between two keys. +data Range = -- | Invariant: \(k_L \le k_R\). + UnsafeRange + {-# UNPACK #-} !Key -- ^ \(k_L\) + {-# UNPACK #-} !Key -- ^ \(k_R\) + +instance Show Range where + showsPrec d (UnsafeRange kL kR) = + showParen (d > 10) $ + showString "Range " . shows kL + . showChar ' ' . shows kR + +{-# COMPLETE Range #-} +-- | Reorders endpoints to fit mathematical notation: +-- \([12, 3]\) will be converted to \([3, 12]\). +-- +-- Pattern matching guarantees \(k_1 \le k_2\). +pattern Range + :: Word -- ^ \(k_1\) + -> Word -- ^ \(k_2\) + -> Range +pattern Range kL kR <- UnsafeRange kL kR + where + Range k1 k2 + | k1 <= k2 = UnsafeRange k1 k2 + | otherwise = UnsafeRange k2 k1 diff --git a/src/Radix/Word/Debug.hs b/src/Radix/Word/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Radix/Word/Debug.hs @@ -0,0 +1,23 @@ +module Radix.Word.Debug + ( S (..) + , validBelow + ) where + +import Radix.Word.Foundation + +import Data.Bits + + + +-- | Branch side. +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 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 diff --git a/src/Radix/Word/Foundation.hs b/src/Radix/Word/Foundation.hs new file mode 100644 --- /dev/null +++ b/src/Radix/Word/Foundation.hs @@ -0,0 +1,68 @@ +module Radix.Word.Foundation + ( Key + , Prefix + , Mask + + , beyond + , upper + , lower + + , zeroBit + , mask + , branchingBit + ) where + +import Data.Bits + + + +-- | Key as stored in the data structure. +type Key = Word + +-- | Part of the 'Key' from the largest bit to the 'Mask' bit, plus the 'Mask' bit. +type Prefix = Word + +{-# INLINE beyond #-} +-- | \(\mathcal{O}(1)\). +-- Whether the key does not match the prefix. +beyond :: Prefix -> Key -> Bool +beyond p k = (k `xor` p) .&. (p `xor` negate p) /= 0 + +{-# INLINE upper #-} +-- | \(\mathcal{O}(1)\). +-- Largest key that can reside under this prefix. +upper :: Prefix -> Key +upper p = p .|. (p - 1) + +{-# INLINE lower #-} +-- | \(\mathcal{O}(1)\). +-- Smallest key that can reside under this prefix. +lower :: Prefix -> Key +lower p = p .&. (p - 1) + + + +-- | Masking bit. +type Mask = Word + +{-# INLINE zeroBit #-} +-- | \(\mathcal{O}(1)\). +-- Get the state of the masked bit from the 'Key'. +zeroBit :: Key -> Mask -> Bool +zeroBit k m = (k .&. m) == 0 + +{-# INLINE mask #-} +-- | \(\mathcal{O}(1)\). +-- Trim the 'Key' down to the masking bit. +mask :: Key -> Mask -> Word +mask k m = k .&. (negate m `xor` m) + +{-# INLINE branchingBit #-} +-- | \(\mathcal{O}(1)\). +-- Find the bit two 'Prefix'es disagree on. +-- +-- Note that using this function on two equal integers yields @1 << (-1)@, +-- which results in undefined behavior. +branchingBit :: Prefix -> Prefix -> Mask +branchingBit p o = + 1 `unsafeShiftL` (finiteBitSize (0 :: Word) - 1 - countLeadingZeros (p `xor` o)) diff --git a/src/Radix/Word8/Common.hs b/src/Radix/Word8/Common.hs new file mode 100644 --- /dev/null +++ b/src/Radix/Word8/Common.hs @@ -0,0 +1,10 @@ +module Radix.Word8.Common + ( Location (..) + ) where + + + +-- | Whether the cursor point to a point within the tree. +data Location = Inside + | Outside + deriving Show diff --git a/src/Radix/Word8/Debug.hs b/src/Radix/Word8/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Radix/Word8/Debug.hs @@ -0,0 +1,23 @@ +module Radix.Word8.Debug + ( S (..) + , validBelow + ) where + +import Radix.Word8.Foundation + +import Data.Bits + + + +-- | Branch side. +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 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 diff --git a/src/Radix/Word8/Foundation.hs b/src/Radix/Word8/Foundation.hs new file mode 100644 --- /dev/null +++ b/src/Radix/Word8/Foundation.hs @@ -0,0 +1,62 @@ +module Radix.Word8.Foundation + ( Key + , Prefix + , Mask + + , beyond + , upper + , lower + + , zeroBit + , mask + , branchingBit + ) where + +import Data.Bits +import Data.Word + + + +-- | Key as stored in the data structure. +type Key = Word8 + +-- | Part of the 'Key' from the largest bit to the 'Mask' bit, plus the 'Mask' bit. +type Prefix = Word8 + +{-# INLINE beyond #-} +-- | \(\mathcal{O}(1)\). +-- Whether the key does not match the prefix. +beyond :: Prefix -> Key -> Bool +beyond p k = (k `xor` p) .&. (p `xor` negate p) /= 0 + +{-# INLINE upper #-} +-- | \(\mathcal{O}(1)\). +-- Largest key that can reside under this prefix. +upper :: Prefix -> Key +upper p = p .|. (p - 1) + +{-# INLINE lower #-} +-- | \(\mathcal{O}(1)\). +-- Smallest key that can reside under this prefix. +lower :: Prefix -> Key +lower p = p .&. (p - 1) + + + +-- | Masking bit. +type Mask = Word8 + +{-# INLINE zeroBit #-} +-- | Get the state of the masked bit from the 'Key'. +zeroBit :: Key -> Mask -> Bool +zeroBit k m = (k .&. m) == 0 + +{-# INLINE mask #-} +-- | Trim the 'Key' down to a 'Prefix'. +mask :: Key -> Mask -> Prefix +mask k m = k .&. (negate m `xor` m) + +{-# INLINE branchingBit #-} +-- | Finds the bit the two 'Prefix'es disagree on. +branchingBit :: Prefix -> Prefix -> Mask +branchingBit p o = 1 `unsafeShiftL` (7 - countLeadingZeros (p `xor` o)) diff --git a/test/TestMain.hs b/test/TestMain.hs deleted file mode 100644 --- a/test/TestMain.hs +++ /dev/null @@ -1,119 +0,0 @@ ----------------------------------------------------------------------------- --- | --- Module : TestMain --- Copyright : (c) Sergey Vinokurov 2018 --- License : BSD3-style (see LICENSE) --- Maintainer : serg.foo@gmail.com ----------------------------------------------------------------------------- - -{-# LANGUAGE ScopedTypeVariables #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Main (main) where - -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as BSS - -import Data.Char -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -import Data.RadixTree (RadixTree) -import qualified Data.RadixTree as RT -import Data.Word - -import Test.QuickCheck -import Test.QuickCheck.Poly -import Test.Tasty -import Test.Tasty.QuickCheck as QC - -newtype AsciiChar = AsciiChar { unAsciiChar :: Char } - -instance Arbitrary AsciiChar where - arbitrary = AsciiChar <$> choose ('a', 'z') - shrink (AsciiChar 'a') = [] - shrink (AsciiChar c) = [AsciiChar c' | c' <- ['a'..pred c]] - -mkAsciiChar :: Word8 -> AsciiChar -mkAsciiChar = AsciiChar . chr. fromIntegral - -asciiByte :: AsciiChar -> Word8 -asciiByte = fromIntegral . ord . unAsciiChar - -instance Arbitrary ShortByteString where - arbitrary = - BSS.pack . map asciiByte <$> listOf arbitrary - shrink = - map (BSS.pack . map asciiByte) . shrink . map mkAsciiChar . BSS.unpack - -instance Arbitrary a => Arbitrary (RadixTree a) where - arbitrary = RT.fromList <$> arbitrary - shrink = map RT.fromList . shrink . RT.toAscList - -main :: IO () -main = defaultMain tests - -tests :: TestTree -tests = testGroup "Tests" [properties] - -properties :: TestTree -properties = testGroup "Properties" [qcProps] - -qcProps :: TestTree -qcProps = adjustOption (\(QuickCheckTests n) -> QuickCheckTests (max 10000 n)) $ testGroup "radix tree" - [ QC.testProperty "∀ t: RT.lookup k (RT.insert k v t) == v" $ - \(t :: RadixTree A) (k :: ShortByteString) (v :: A) -> - RT.lookup k (RT.insert k v t) == Just v - , QC.testProperty "∀ t: RT.lookup k (RT.insert k v2 (RT.insert k v1 t)) == v2" $ - \(t :: RadixTree A) (k :: ShortByteString) (v1 :: A) (v2 :: A) -> - RT.lookup k (RT.insert k v2 (RT.insert k v1 t)) == Just v2 - - , QC.testProperty "∀ xs: RT.fromList xs == M.fromList xs" $ - \(xs :: [(ShortByteString, A)]) -> - RT.toAscList (RT.fromList xs) == M.toAscList (M.fromList xs) - - , QC.testProperty "∀ xs: RT.size (RT.fromList xs) == M.size (M.fromList xs)" $ - \(xs :: [(ShortByteString, A)]) -> - RT.size (RT.fromList xs) == M.size (M.fromList xs) - - , QC.testProperty "∀ f: RT.mapMaybe f == M.mapMaybe f" $ - \(f :: Fun A (Maybe B)) -> - RT.mapMaybe (applyFun f) ==== M.mapMaybe (applyFun f) - - , QC.testProperty "∀ k v t: RT.insert k v t == M.insert k v t" $ - \(k :: ShortByteString) (v :: A) -> - RT.insert k v ==== M.insert k v - - , QC.testProperty "∀ f xs ys: RT.mergeWith f xs ys == M.mergeWith f xs ys" $ - \(f :: Fun (A, A) A) -> - RT.unionWith (curry (applyFun f)) ===== M.unionWith (curry (applyFun f)) - ] - -(====) - :: Eq b - => (RadixTree a -> RadixTree b) - -> (Map ShortByteString a -> Map ShortByteString b) - -> [(ShortByteString, a)] - -> Bool -(====) f g xs = - RT.toAscList (f (RT.fromList xs)) == M.toAscList (g (M.fromList xs)) - -(=====) - :: Eq a - => (RadixTree a -> RadixTree a -> RadixTree a) - -> (Map ShortByteString a -> Map ShortByteString a -> Map ShortByteString a) - -> [(ShortByteString, a)] - -> [(ShortByteString, a)] - -> Bool -(=====) f g xs ys = - RT.toAscList (f (RT.fromList xs) (RT.fromList ys)) == M.toAscList (g (M.fromList xs) (M.fromList ys)) - --- unitTests :: TestTree --- unitTests = testGroup "Unit tests" --- [ testCase "List comparison (different length)" $ --- [1, 2, 3] `compare` [1,2] @?= GT --- --- -- the following test does not hold --- , testCase "List comparison (same length)" $ --- [1, 2, 3] `compare` [1,2,2] @?= LT --- ] diff --git a/test/properties/Main.hs b/test/properties/Main.hs new file mode 100644 --- /dev/null +++ b/test/properties/Main.hs @@ -0,0 +1,33 @@ +module Main where + +import qualified Test.Patricia.Word.Lazy as Pat.Lazy +import qualified Test.Patricia.Word.Strict as Pat.Strict +import qualified Test.RadixTree.Word8.Lazy as Radix.Lazy +import qualified Test.RadixTree.Word8.Strict as Radix.Strict +import qualified Test.RadixNTree.Word8.Key as Radix.Key +import qualified Test.Zebra.Word as Zebra + +import Test.Hspec + + + +main :: IO () +main = + hspec $ do + describe "Patricia/Lazy" $ + Pat.Lazy.test + + describe "Patricia/Strict" $ + Pat.Strict.test + + describe "RadixNTree/Key" $ + Radix.Key.test + + describe "RadixTree/Lazy" $ + Radix.Lazy.test + + describe "RadixTree/Strict" $ + Radix.Strict.test + + describe "Zebra" $ + Zebra.test diff --git a/test/properties/Test/Kit.hs b/test/properties/Test/Kit.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/Kit.hs @@ -0,0 +1,60 @@ +module Test.Kit + ( Case (..) + , augment + + , Test (..) + + , run + , dump + ) where + +import Control.Exception +import Data.Foldable + + + +data Case s a b = Case s a b + +augment :: (s -> t) -> [Case s a b] -> [Case t a b] +augment f xs = fmap (\(Case s a b) -> Case (f s) a b) xs + + + +data Test s a b x y = Test (x -> y -> Bool) (s -> a -> x) (s -> b -> y) + + + +newtype Failure = Failure Int + +instance Show Failure where + showsPrec _ (Failure n) = showString "Test failed on case " . shows n + +instance Exception Failure + + + +newtype UnknownIndex = UnknownIndex Int + +instance Show UnknownIndex where + showsPrec _ (UnknownIndex n) = showString "No case under index " . shows n + +instance Exception UnknownIndex + + + +enumerate :: [Case s a b] -> [(Int, Case s a b)] +enumerate = zip [0..] + +run :: [Case s a b] -> Test s a b x y -> IO () +run cs (Test cmp f g) = traverse_ go $ enumerate cs + where + go (n, Case s a b) = + if cmp (f s a) (g s b) + then pure () + else throwIO (Failure n) + +dump :: [Case s a b] -> Test s a b x y -> Int -> IO (s, a, b, x, y) +dump xs (Test _ f g) n = + case lookup n (enumerate xs) of + Just (Case s a b) -> pure (s, a, b, f s a, g s b) + Nothing -> throwIO (UnknownIndex n) diff --git a/test/properties/Test/Patricia/Word/Lazy.hs b/test/properties/Test/Patricia/Word/Lazy.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/Patricia/Word/Lazy.hs @@ -0,0 +1,795 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.Patricia.Word.Lazy + ( test + ) where + +import Data.Patricia.Word.Lazy (Patricia) +import qualified Data.Patricia.Word.Lazy as Pat +import Data.Patricia.Word.Lazy.Debug (validate, Validity (..)) +import qualified Data.Patricia.Word.Lazy.Unsafe as Pat +import No.Tree (NoTree) +import qualified No.Tree as No +import Test.Patricia.Word.Sample +import Test.Kit + +import Data.Functor.Identity +import Test.Hspec + + + +patFromList :: [(Word, a)] -> Patricia a +patFromList = foldr (\(k, a) p -> Pat.insert k a p) Pat.empty + +patToList :: Patricia a -> [(Word, a)] +patToList = Pat.foldrWithKey (\k a -> (:) (k, a)) [] + + + +patRange :: (Pat.Range -> a -> b) -> (Word, Word, a) -> b +patRange f (k1, k2, a) = f (Pat.Range k1 k2) a + +patRange_ :: (Pat.Range -> b) -> (Word, Word) -> b +patRange_ f (k1, k2) = f (Pat.Range k1 k2) + +noRange :: (No.Range Word -> a -> b) -> (Word, Word, a) -> b +noRange f (k1, k2, a) = f (No.WordRange No.Closed k1 No.Closed k2) a + +noRange_ :: (No.Range Word -> b) -> (Word, Word) -> b +noRange_ f (k1, k2) = f (No.WordRange No.Closed k1 No.Closed k2) + + + +unary0 :: [Case () (Patricia Int) (NoTree Word Int)] +unary0 = foldMap (mkUnary0 patFromList) [zero, one, tiny, small, medium] -- , large] + +unary1 :: [Case (Word, Int) (Patricia Int) (NoTree Word Int)] +unary1 = foldMap (mkUnary1 patFromList) [zero, one, tiny, small, medium] -- , large] + +unary1_ :: [Case Word (Patricia Int) (NoTree Word Int)] +unary1_ = augment fst unary1 + +unary2 :: [Case (Word, Word, Int) (Patricia Int) (NoTree Word Int)] +unary2 = foldMap (mkUnary2 patFromList) [zero, one, tiny, small, medium] -- , large] + +unary2_ :: [Case (Word, Word) (Patricia Int) (NoTree Word Int)] +unary2_ = augment (\(k1, k2, _) -> (k1, k2)) unary2 + +binary + , binaryL + , subset + , superset + , equal + :: [Case (Patricia Int, NoTree Word Int) (Patricia Int) (NoTree Word Int)] +binary = foldMap (mkBinary patFromList) [zero, one, tiny, small, medium] -- , large] +binaryL = foldMap (mkBinaryL patFromList) [zero, one, tiny, small, medium] -- , large] +subset = foldMap (mkSubset patFromList) [zero, one, tiny, small, medium] -- , large] +superset = foldMap (mkSuperset patFromList) [zero, one, tiny, small, medium] -- , large] +equal = foldMap (mkEqual patFromList) [zero, one, tiny, small, medium] -- , large] + + + +type IdT s a b = Test s (Patricia a) (NoTree Word a) b b + +type TreeT s a = Test s (Patricia a) (NoTree Word a) (Patricia a) (NoTree Word a) + +treeEq :: Eq a => Patricia a -> NoTree Word a -> Bool +treeEq pat no = + case validate pat of + Valid -> patToList pat == No.toList no + _ -> False + +type SplitT s a = + Test s (Patricia a) (NoTree Word a) + (Patricia a, Patricia a) (NoTree Word a, NoTree Word a) + +splitEq + :: Eq a => (Patricia a, Patricia a) -> (NoTree Word a, NoTree Word a) -> Bool +splitEq (a, b) (x, y) = treeEq a x && treeEq b y + +type SplitLookupT s a = + Test s (Patricia a) (NoTree Word a) + (Patricia a, Maybe a, Patricia a) (NoTree Word a, Maybe a, NoTree Word a) + +splitLookupEq + :: Eq a + => (Patricia a, Maybe a, Patricia a) -> (NoTree Word a, Maybe a, NoTree Word a) -> Bool +splitLookupEq (a, b, c) (x, y, z) = treeEq a x && b == y && treeEq c z + +type LookupT s a = + Test s (Patricia a) (NoTree Word a) (Maybe (Pat.Lookup a)) (Maybe (Word, a)) + +lookupEq :: Eq a => Maybe (Pat.Lookup a) -> Maybe (Word, a) -> Bool +lookupEq (Just (Pat.Lookup k a)) (Just (l, b)) = k == l && a == b +lookupEq Nothing Nothing = True +lookupEq _ _ = False + +type MinViewT s a = + Test s (Patricia a) (NoTree Word a) + (Maybe (Pat.ViewL a)) (Maybe (Word, a, NoTree Word a)) + +minViewEq :: Eq a => Maybe (Pat.ViewL a) -> Maybe (Word, a, NoTree Word a) -> Bool +minViewEq (Just (Pat.ViewL (Pat.Lookup k a) pat)) (Just (l, b, no)) = + k == l && a == b && treeEq pat no + +minViewEq Nothing Nothing = True +minViewEq _ _ = False + +type MaxViewT s a = + Test s (Patricia a) (NoTree Word a) + (Maybe (Pat.ViewR a)) (Maybe (NoTree Word a, Word, a)) + +maxViewEq :: Eq a => Maybe (Pat.ViewR a) -> Maybe (NoTree Word a, Word, a) -> Bool +maxViewEq (Just (Pat.ViewR pat (Pat.Lookup k a))) (Just (no, l, b)) = + k == l && a == b && treeEq pat no + +maxViewEq Nothing Nothing = True +maxViewEq _ _ = False + + + +lookupT :: Eq a => IdT Word a (Maybe a) +lookupT = Test (==) Pat.lookup No.lookup + +findT :: Eq a => IdT (Word, a) a a +findT = Test (==) (\(k, a) -> Pat.find a k) (\(k, a) -> No.find a k) + +memberT :: IdT Word a Bool +memberT = Test (==) Pat.member No.member + + + +insertT :: Eq a => TreeT (Word, a) a +insertT = Test treeEq (uncurry Pat.insert) (uncurry No.insert) + +insertWithT :: (Eq a, Integral a) => TreeT (Word, a) a +insertWithT = + let f x = (+ fromIntegral x) + in Test treeEq + (\(k, a) -> Pat.insertWith (f a) k a) + (\(k, a) -> No.insertWith (f a) k a) + +adjustT :: (Eq a, Integral a) => TreeT (Word, a) a +adjustT = + let f a = (+ fromIntegral a) + in Test treeEq (\(k, a) -> Pat.adjust (f a) k) (\(k, a) -> No.adjust (f a) k) + +deleteT :: Eq a => TreeT Word a +deleteT = Test treeEq Pat.delete No.delete + +updateAdjustT, updateDeleteT :: (Eq a, Integral a) => TreeT (Word, a) a +updateAdjustT = updateT_ (\a -> Just . (+ a)) +updateDeleteT = updateT_ (\_ _ -> Nothing) + +updateT_ :: Eq a => (a -> a -> Maybe a) -> TreeT (Word, a) a +updateT_ f = Test treeEq (\(k, a) -> Pat.update (f a) k) (\(k, a) -> No.update (f a) k) + +alterInsertT + , alterInsertWithT + , alterAdjustT + , alterDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +alterInsertT = alterT_ (\a _ -> Just a) +alterInsertWithT = alterT_ (\a -> Just . maybe a (+ a)) +alterAdjustT = alterT_ (\a -> fmap (+ a)) +alterDeleteT = alterT_ (\_ _ -> Nothing) + +alterT_ :: Eq a => (a -> Maybe a -> Maybe a) -> TreeT (Word, a) a +alterT_ f = Test treeEq (\(k, a) -> Pat.alter (f a) k) (\(k, a) -> No.alter (f a) k) + + + +splitLT :: Eq a => SplitT Word a +splitLT = Test splitEq Pat.splitL (No.splitL No.Closed) + +splitRT :: Eq a => SplitT Word a +splitRT = Test splitEq Pat.splitR No.splitR + +splitLookupT :: Eq a => SplitLookupT Word a +splitLookupT = Test splitLookupEq Pat.splitLookup No.splitLookup + + + +lookupLT :: Eq a => LookupT Word a +lookupLT = Test lookupEq Pat.lookupL (No.lookupL No.Closed) + +adjustLT :: (Eq a, Integral a) => TreeT (Word, a) a +adjustLT = + let f a = (+ a) + in Test treeEq + (\(k, a) -> Pat.adjustL (f a) k) + (\(k, a) -> No.adjustL (f a) No.Closed k) + +adjustLWithKeyT :: (Eq a, Integral a) => TreeT (Word, a) a +adjustLWithKeyT = + let f a k = (+ fromIntegral k) . (+ a) + in Test treeEq + (\(k, a) -> Pat.adjustLWithKey (f a) k) + (\(k, a) -> No.adjustLWithKey (f a) No.Closed k) + +deleteLT :: Eq a => TreeT (Word) a +deleteLT = Test treeEq Pat.deleteL (No.deleteL No.Closed) + +updateLAdjustT + , updateLDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +updateLAdjustT = updateLT_ (\a -> Just . (+ a)) +updateLDeleteT = updateLT_ (\_ _ -> Nothing) + +updateLT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (Word, a) a +updateLT_ f = + Test treeEq (\(k, a) -> Pat.updateL (f a) k) (\(k, a) -> No.updateL (f a) No.Closed k) + +updateLWithKeyAdjustT + , updateLWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +updateLWithKeyAdjustT = updateLWithKeyT_ (\a k -> Just . (+ fromIntegral k) . (+ a)) +updateLWithKeyDeleteT = updateLWithKeyT_ (\_ _ _ -> Nothing) + +updateLWithKeyT_ + :: (Eq a, Integral a) + => (a -> Word -> a -> Maybe a) -> TreeT (Word, a) a +updateLWithKeyT_ f = + Test treeEq (\(k, a) -> Pat.updateLWithKey (f a) k) + (\(k, a) -> No.updateLWithKey (f a) No.Closed k) + +takeLT :: Eq a => TreeT (Word) a +takeLT = Test treeEq Pat.takeL (No.takeL No.Closed) + + + +lookupRT :: Eq a => LookupT (Word) a +lookupRT = Test lookupEq Pat.lookupR (No.lookupR No.Closed) + +adjustRT :: (Eq a, Integral a) => TreeT (Word, a) a +adjustRT = + let f a = (+ a) + in Test treeEq + (\(k, a) -> Pat.adjustR (f a) k) + (\(k, a) -> No.adjustR (f a) No.Closed k) + +adjustRWithKeyT :: (Eq a, Integral a) => TreeT (Word, a) a +adjustRWithKeyT = + let f a k = (+ fromIntegral k) . (+ a) + in Test treeEq + (\(k, a) -> Pat.adjustRWithKey (f a) k) + (\(k, a) -> No.adjustRWithKey (f a) No.Closed k) + +deleteRT :: Eq a => TreeT (Word) a +deleteRT = Test treeEq Pat.deleteR (No.deleteR No.Closed) + +updateRAdjustT + , updateRDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +updateRAdjustT = updateRT_ (\a -> Just . (+ a)) +updateRDeleteT = updateRT_ (\_ _ -> Nothing) + +updateRT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (Word, a) a +updateRT_ f = + Test treeEq (\(k, a) -> Pat.updateR (f a) k) (\(k, a) -> No.updateR (f a) No.Closed k) + +updateRWithKeyAdjustT + , updateRWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +updateRWithKeyAdjustT = updateRWithKeyT_ (\a k -> Just . (+ fromIntegral k) . (+ a)) +updateRWithKeyDeleteT = updateRWithKeyT_ (\_ _ _ -> Nothing) + +updateRWithKeyT_ + :: (Eq a, Integral a) + => (a -> Word -> a -> Maybe a) -> TreeT (Word, a) a +updateRWithKeyT_ f = + Test treeEq (\(k, a) -> Pat.updateRWithKey (f a) k) + (\(k, a) -> No.updateRWithKey (f a) No.Closed k) + +takeRT :: Eq a => TreeT (Word) a +takeRT = Test treeEq Pat.takeR (No.takeR No.Closed) + + + +adjustRangeT :: (Eq a, Integral a) => TreeT (Word, Word, a) a +adjustRangeT = + let f a = (+ a) + in Test treeEq + (patRange $ \r a -> Pat.adjustRange (f a) r) + (noRange $ \r a -> No.adjustRange (f a) r) + +adjustRangeWithKeyT :: (Eq a, Integral a) => TreeT (Word, Word, a) a +adjustRangeWithKeyT = + let f a k = (+ fromIntegral k) . (+ a) + in Test treeEq + (patRange $ \r a -> Pat.adjustRangeWithKey (f a) r) + (noRange $ \r a -> No.adjustRangeWithKey (f a) r) + +deleteRangeT :: Eq a => TreeT (Word, Word) a +deleteRangeT = Test treeEq (patRange_ Pat.deleteRange) (noRange_ No.deleteRange) + +updateRangeAdjustT + , updateRangeDeleteT + :: (Eq a, Integral a) => TreeT (Word, Word, a) a +updateRangeAdjustT = updateRangeT_ (\a -> Just . (+ a)) +updateRangeDeleteT = updateRangeT_ (\_ _ -> Nothing) + +updateRangeT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (Word, Word, a) a +updateRangeT_ f = + Test treeEq + (patRange $ \r a -> Pat.updateRange (f a) r) (noRange $ \r a -> No.updateRange (f a) r) + +updateRangeWithKeyAdjustT + , updateRangeWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (Word, Word, a) a +updateRangeWithKeyAdjustT = updateRangeWithKeyT_ (\a k -> Just . (+ fromIntegral k) . (+ a)) +updateRangeWithKeyDeleteT = updateRangeWithKeyT_ (\_ _ _ -> Nothing) + +updateRangeWithKeyT_ + :: (Eq a, Integral a) + => (a -> Word -> a -> Maybe a) -> TreeT (Word, Word, a) a +updateRangeWithKeyT_ f = + Test treeEq (patRange $ \r a -> Pat.updateRangeWithKey (f a) r) + (noRange $ \r a -> No.updateRangeWithKey (f a) r) + + + +takeRangeT :: Eq a => TreeT (Word, Word) a +takeRangeT = Test treeEq (patRange_ Pat.takeRange) (noRange_ No.takeRange) + + + +lookupMinT :: Eq a => IdT () a (Maybe a) +lookupMinT = Test (==) (\_ -> Pat.lookupMin) (\_ -> No.lookupMin) + +lookupMinWithKeyT :: Eq a => LookupT () a +lookupMinWithKeyT = Test lookupEq (\_ -> Pat.lookupMinWithKey) (\_ -> No.lookupMinWithKey) + +adjustMinT :: (Eq a, Integral a) => TreeT () a +adjustMinT = Test treeEq (\_ -> Pat.adjustMin (+ 10000)) (\_ -> No.adjustMin (+ 10000)) + +adjustMinWithKeyT :: (Eq a, Integral a) => TreeT () a +adjustMinWithKeyT = + let f k = (+ fromIntegral k) + in Test treeEq (\_ -> Pat.adjustMinWithKey f) (\_ -> No.adjustMinWithKey f) + +deleteMinT :: (Eq a, Integral a) => TreeT () a +deleteMinT = Test treeEq (\_ -> Pat.deleteMin) (\_ -> No.deleteMin) + +updateMinAdjustT, updateMinDeleteT :: (Eq a, Integral a) => TreeT () a +updateMinAdjustT = updateMinT_ (Just . (+ 10000)) +updateMinDeleteT = updateMinT_ (\_ -> Nothing) + +updateMinT_ :: (Eq a, Integral a) => (a -> Maybe a) -> TreeT () a +updateMinT_ f = Test treeEq (\_ -> Pat.updateMin f) (\_ -> No.updateMin f) + +updateMinWithKeyAdjustT, updateMinWithKeyDeleteT :: (Eq a, Integral a) => TreeT () a +updateMinWithKeyAdjustT = updateMinWithKeyT_ (\k -> Just . (+ fromIntegral k)) +updateMinWithKeyDeleteT = updateMinWithKeyT_ (\_ _ -> Nothing) + +updateMinWithKeyT_ :: (Eq a, Integral a) => (Word -> a -> Maybe a) -> TreeT () a +updateMinWithKeyT_ f = + Test treeEq (\_ -> Pat.updateMinWithKey f) (\_ -> No.updateMinWithKey f) + +minViewT :: Eq a => MinViewT () a +minViewT = Test minViewEq (\_ -> Pat.minView) (\_ -> No.minView) + + + +lookupMaxT :: Eq a => IdT () a (Maybe a) +lookupMaxT = Test (==) (\_ -> Pat.lookupMax) (\_ -> No.lookupMax) + +lookupMaxWithKeyT :: Eq a => LookupT () a +lookupMaxWithKeyT = Test lookupEq (\_ -> Pat.lookupMaxWithKey) (\_ -> No.lookupMaxWithKey) + +adjustMaxT :: (Eq a, Integral a) => TreeT () a +adjustMaxT = Test treeEq (\_ -> Pat.adjustMax (+ 10000)) (\_ -> No.adjustMax (+ 10000)) + +adjustMaxWithKeyT :: (Eq a, Integral a) => TreeT () a +adjustMaxWithKeyT = + let f k = (+ fromIntegral k) + in Test treeEq (\_ -> Pat.adjustMaxWithKey f) (\_ -> No.adjustMaxWithKey f) + +deleteMaxT :: (Eq a, Integral a) => TreeT () a +deleteMaxT = Test treeEq (\_ -> Pat.deleteMax) (\_ -> No.deleteMax) + +updateMaxAdjustT, updateMaxDeleteT :: (Eq a, Integral a) => TreeT () a +updateMaxAdjustT = updateMaxT_ (Just . (+ 10000)) +updateMaxDeleteT = updateMaxT_ (\_ -> Nothing) + +updateMaxT_ :: (Eq a, Integral a) => (a -> Maybe a) -> TreeT () a +updateMaxT_ f = Test treeEq (\_ -> Pat.updateMax f) (\_ -> No.updateMax f) + +updateMaxWithKeyAdjustT, updateMaxWithKeyDeleteT :: (Eq a, Integral a) => TreeT () a +updateMaxWithKeyAdjustT = updateMaxWithKeyT_ (\k -> Just . (+ fromIntegral k)) +updateMaxWithKeyDeleteT = updateMaxWithKeyT_ (\_ _ -> Nothing) + +updateMaxWithKeyT_ :: (Eq a, Integral a) => (Word -> a -> Maybe a) -> TreeT () a +updateMaxWithKeyT_ f = + Test treeEq (\_ -> Pat.updateMaxWithKey f) (\_ -> No.updateMaxWithKey f) + +maxViewT :: Eq a => MaxViewT () a +maxViewT = Test maxViewEq (\_ -> Pat.maxView) (\_ -> No.maxView) + + + +eqT :: (Eq a, Integral a) => IdT (Pat.Patricia a, NoTree Word a) a Bool +eqT = Test (==) (\(a, _) b -> a == b) (\(_, a) b -> a == b) + +filterT :: (Eq a, Integral a) => TreeT () a +filterT = Test treeEq (\_ -> Pat.filter odd) (\_ -> No.filter odd) + +filterWithKeyT :: (Eq a, Integral a) => TreeT () a +filterWithKeyT = + let f k a = odd $ fromIntegral k + a + in Test treeEq (\_ -> Pat.filterWithKey f) (\_ -> No.filterWithKey f) + +mapMaybeT :: (Eq a, Integral a) => TreeT () a +mapMaybeT = + let f a | odd a = Nothing + | otherwise = Just a + + in Test treeEq (\_ -> Pat.mapMaybe f) (\_ -> No.mapMaybe f) + +mapMaybeWithKeyT :: (Eq a, Integral a) => TreeT () a +mapMaybeWithKeyT = + let f k a | odd (fromIntegral k + a) = Nothing + | otherwise = Just a + + in Test treeEq (\_ -> Pat.mapMaybeWithKey f) (\_ -> No.mapMaybeWithKey f) + +partitionT :: (Eq a, Integral a) => SplitT () a +partitionT = Test splitEq (\_ -> Pat.partition odd) (\_ -> No.partition odd) + +partitionWithKeyT :: (Eq a, Integral a) => SplitT () a +partitionWithKeyT = + let f k a = odd $ fromIntegral k + a + in Test splitEq (\_ -> Pat.partitionWithKey f) (\_ -> No.partitionWithKey f) + +mapEitherT :: (Eq a, Integral a) => SplitT () a +mapEitherT = + let f a | odd a = Left a + | otherwise = Right a + + in Test splitEq (\_ -> Pat.mapEither f) (\_ -> No.mapEither f) + +mapEitherWithKeyT :: (Eq a, Integral a) => SplitT () a +mapEitherWithKeyT = + let f k a | odd (fromIntegral k + a) = Left a + | otherwise = Right a + + in Test splitEq (\_ -> Pat.mapEitherWithKey f) (\_ -> No.mapEitherWithKey f) + + + +mapT :: (Eq a, Num a) => TreeT () a +mapT = + let f = (+ 10000) + in Test treeEq (\_ -> Pat.map f) (\_ -> No.map f) + +mapWithKeyT :: (Eq a, Num a) => TreeT () a +mapWithKeyT = + let f k = (+ fromIntegral k) . (+ 10000) + in Test treeEq (\_ -> Pat.mapWithKey f) (\_ -> No.mapWithKey f) + + + +sizeT :: IdT () a Int +sizeT = Test (==) (\_ -> Pat.size) (\_ -> No.size) + +foldlT, foldlT' :: Eq a => IdT () a [a] +foldlT = foldlT_ Pat.foldl +foldlT' = foldlT_ Pat.foldl' + +foldlT_ :: Eq a => (forall x. (x -> a -> x) -> x -> Patricia a -> x) -> IdT () a [a] +foldlT_ g = Test (==) (\_ -> g (flip (:)) []) (\_ -> No.foldl (flip (:)) []) + +foldlWithKeyT, foldlWithKeyT' :: Eq a => IdT () a [(Word, a)] +foldlWithKeyT = foldlWithKeyT_ Pat.foldlWithKey +foldlWithKeyT' = foldlWithKeyT_ Pat.foldlWithKey' + +foldlWithKeyT_ + :: Eq a + => (forall x. (x -> Word -> a -> x) -> x -> Patricia a -> x) -> IdT () a [(Word, a)] +foldlWithKeyT_ g = + let f z k a = (k, a) : z + in Test (==) (\_ -> g f []) (\_ -> No.foldlWithKey f []) + + + +foldrT, foldrT' :: Eq a => IdT () a [a] +foldrT = foldrT_ Pat.foldr +foldrT' = foldrT_ Pat.foldr' + +foldrT_ + :: Eq a => (forall x. (a -> x -> x) -> x -> Patricia a -> x) -> IdT () a [a] +foldrT_ g = Test (==) (\_ -> g (:) []) (\_ -> No.foldr (:) []) + +foldrWithKeyT, foldrWithKeyT' :: Eq a => IdT () a [(Word, a)] +foldrWithKeyT = foldrWithKeyT_ Pat.foldrWithKey +foldrWithKeyT' = foldrWithKeyT_ Pat.foldrWithKey' + +foldrWithKeyT_ + :: Eq a + => (forall x. (Word -> a -> x -> x) -> x -> Patricia a -> x) -> IdT () a [(Word, a)] +foldrWithKeyT_ g = + let f k a = (:) (k, a) + in Test (==) (\_ -> g f []) (\_ -> No.foldrWithKey f []) + + + +foldMapT :: Eq a => IdT () a [a] +foldMapT = Test (==) (\_ -> Pat.foldMap pure) (\_ -> No.foldMap pure) + +foldMapWithKeyT :: Eq a => IdT () a [(Word, a)] +foldMapWithKeyT = + let f k a = [(k, a)] + in Test (==) (\_ -> Pat.foldMapWithKey f) (\_ -> No.foldMapWithKey f) + + + +idTreeEq :: Eq a => Identity (Patricia a) -> Identity (NoTree Word a) -> Bool +idTreeEq (Identity a) (Identity b) = treeEq a b + +traverseT + :: (Eq a, Num a) + => Test s (Patricia a) (NoTree Word a) (Identity (Patricia a)) (Identity (NoTree Word a)) +traverseT = + let f = Identity . (+ 10000) + in Test idTreeEq (\_ -> Pat.traverse f) (\_ -> No.traverse f) + +traverseWithKeyT + :: (Eq a, Num a) + => Test s (Patricia a) (NoTree Word a) (Identity (Patricia a)) (Identity (NoTree Word a)) +traverseWithKeyT = + let f k a = Identity $ fromIntegral k + 10000 + a + in Test idTreeEq (\_ -> Pat.traverseWithKey f) (\_ -> No.traverseWithKey f) + + + +unionT :: Eq a => TreeT (Patricia a, NoTree Word a) a +unionT = Test treeEq (\(a, _) b -> Pat.union a b) (\(_, a) b -> No.unionL a b) + +unionLT :: Eq a => TreeT (Patricia a, NoTree Word a) a +unionLT = Test treeEq (\(a, _) b -> Pat.unionL a b) (\(_, a) b -> No.unionL a b) + +unionWithT :: (Eq a, Num a) => TreeT (Patricia a, NoTree Word a) a +unionWithT = Test treeEq (\(a, _) b -> Pat.unionWith (+) a b) + (\(_, a) b -> No.unionWithKey (\_ -> (+)) a b) + +unionWithKeyT + , mergeUnionT + :: (Eq a, Num a) => TreeT (Patricia a, NoTree Word a) a +unionWithKeyT = unionWithKeyT_ Pat.unionWithKey +mergeUnionT = + unionWithKeyT_ $ \f -> + Pat.merge + (\k a b -> Pat.Tip k $ f k a b) + Pat.Tip Pat.Bin Pat.Tip Pat.Bin + +unionWithKeyT_ + :: (Eq a, Num a) + => (forall x. (Word -> x -> x -> x) -> Patricia x -> Patricia x -> Patricia x) + -> TreeT (Patricia a, NoTree Word a) a +unionWithKeyT_ g = + let f k a b = fromIntegral k + a + b + in Test treeEq (\(a, _) b -> g f a b) + (\(_, a) b -> No.unionWithKey f a b) + + + +differenceT :: Eq a => TreeT (Patricia a, NoTree Word a) a +differenceT = Test treeEq (\(a, _) b -> Pat.difference a b) + (\(_, a) b -> No.difference a b) + +differenceWithT :: (Eq a, Integral a) => TreeT (Patricia a, NoTree Word a) a +differenceWithT = + let f a b = let c = a + b + in if odd c + then Nothing + else Just c + + in Test treeEq (\(a, _) b -> Pat.differenceWith f a b) + (\(_, a) b -> No.differenceWithKey (\_ -> f) a b) + +differenceWithKeyT + , mergeDifferenceT + :: (Eq a, Integral a) => TreeT (Patricia a, NoTree Word a) a +differenceWithKeyT = differenceWithKeyT_ Pat.differenceWithKey +mergeDifferenceT = + differenceWithKeyT_ $ \f -> + Pat.merge + (\k a b -> case f k a b of + Just c -> Pat.Tip k c + Nothing -> Pat.Nil + ) + Pat.Tip Pat.Bin + (\_ _ -> Pat.Nil) (\_ _ _ -> Pat.Nil) + +differenceWithKeyT_ + :: (Eq a, Integral a) + => (forall x y. (Word -> x -> y -> Maybe x) -> Patricia x -> Patricia y -> Patricia x) + -> TreeT (Patricia a, NoTree Word a) a +differenceWithKeyT_ g = + let f k a b = let c = fromIntegral k + a + b + in if odd c + then Nothing + else Just c + + in Test treeEq (\(a, _) b -> g f a b) + (\(_, a) b -> No.differenceWithKey f a b) + + + +disjointT :: IdT (Patricia a, NoTree Word a) a Bool +disjointT = Test (==) (\(a, _) b -> Pat.disjoint a b) + (\(_, a) b -> No.null $ No.intersectionL a b) + +intersectionT :: Eq a => TreeT (Patricia a, NoTree Word a) a +intersectionT = Test treeEq (\(a, _) b -> Pat.intersection a b) + (\(_, a) b -> No.intersectionL a b) + +intersectionLT :: Eq a => TreeT (Patricia a, NoTree Word a) a +intersectionLT = Test treeEq (\(a, _) b -> Pat.intersectionL a b) + (\(_, a) b -> No.intersectionL a b) + +intersectionWithT :: (Eq a, Num a) => TreeT (Patricia a, NoTree Word a) a +intersectionWithT = Test treeEq (\(a, _) b -> Pat.intersectionWith (+) a b) + (\(_, a) b -> No.intersectionWithKey (\_ -> (+)) a b) + +intersectionWithKeyT + , mergeIntersectionT + :: (Eq a, Num a) => TreeT (Patricia a, NoTree Word a) a +intersectionWithKeyT = intersectionWithKeyT_ Pat.intersectionWithKey +mergeIntersectionT = + intersectionWithKeyT_ $ \f -> + Pat.merge + (\k a b -> Pat.Tip k $ f k a b) + (\_ _ -> Pat.Nil) (\_ _ _ -> Pat.Nil) + (\_ _ -> Pat.Nil) (\_ _ _ -> Pat.Nil) + +intersectionWithKeyT_ + :: (Eq a, Num a) + => (forall x y z. (Word -> x -> y -> z) -> Patricia x -> Patricia y -> Patricia z) + -> TreeT (Patricia a, NoTree Word a) a +intersectionWithKeyT_ g = + let f k a b = fromIntegral k + a + b + in Test treeEq (\(a, _) b -> g f a b) + (\(_, a) b -> No.intersectionWithKey f a b) + + + +compareT :: Eq a => IdT (Patricia a, NoTree Word a) a Pat.PartialOrdering +compareT = Test (==) (\(a, _) b -> Pat.compare (==) a b) + (\(_, a) b -> No.compare a b) + + + +test :: Spec +test = do + describe "Single-key" $ do + it "lookup" $ run unary1_ lookupT + it "find" $ run unary1 findT + it "member" $ run unary1_ memberT + it "insert" $ run unary1 insertT + it "insertWith" $ run unary1 insertWithT + it "adjust" $ run unary1 adjustT + it "delete" $ run unary1_ deleteT + it "update/adjust" $ run unary1 updateAdjustT + it "update/delete" $ run unary1 updateDeleteT + it "alter/insert" $ run unary1 alterInsertT + it "alter/insertWith" $ run unary1 alterInsertWithT + it "alter/adjust" $ run unary1 alterAdjustT + it "alter/delete" $ run unary1 alterDeleteT + + describe "Split" $ do + it "splitL" $ run unary1_ splitLT + it "splitR" $ run unary1_ splitRT + it "splitLookup" $ run unary1_ splitLookupT + + describe "Left" $ do + it "lookupL" $ run unary1_ lookupLT + it "adjustL" $ run unary1 adjustLT + it "adjustLWithKey" $ run unary1 adjustLWithKeyT + it "deleteL" $ run unary1_ deleteLT + it "updateL/adjust" $ run unary1 updateLAdjustT + it "updateL/delete" $ run unary1 updateLDeleteT + it "updateLWithKey/adjust" $ run unary1 updateLWithKeyAdjustT + it "updateLWithKey/delete" $ run unary1 updateLWithKeyDeleteT + it "takeL" $ run unary1_ takeLT + + describe "Right" $ do + it "lookupR" $ run unary1_ lookupRT + it "adjustR" $ run unary1 adjustRT + it "adjustRWithKey" $ run unary1 adjustRWithKeyT + it "deleteR" $ run unary1_ deleteRT + it "updateR/adjust" $ run unary1 updateRAdjustT + it "updateR/delete" $ run unary1 updateRDeleteT + it "updateRWithKey/adjust" $ run unary1 updateRWithKeyAdjustT + it "updateRWithKey/delete" $ run unary1 updateRWithKeyDeleteT + it "takeR" $ run unary1_ takeRT + + describe "Range" $ do + it "adjustRange" $ run unary2 adjustRangeT + it "adjustRangeWithKey" $ run unary2 adjustRangeWithKeyT + it "deleteRange" $ run unary2_ deleteRangeT + it "updateRange/adjust" $ run unary2 updateRangeAdjustT + it "updateRange/delete" $ run unary2 updateRangeDeleteT + it "updateRangeWithKey/adjust" $ run unary2 updateRangeWithKeyAdjustT + it "updateRangeWithKey/delete" $ run unary2 updateRangeWithKeyDeleteT + it "takeRange" $ run unary2_ takeRangeT + + describe "Min" $ do + it "lookupMin" $ run unary0 lookupMinT + it "lookupMinWithKey" $ run unary0 lookupMinWithKeyT + it "adjustMin" $ run unary0 adjustMinT + it "adjustMinWithKey" $ run unary0 adjustMinWithKeyT + it "deleteMin" $ run unary0 deleteMinT + it "updateMin/adjust" $ run unary0 updateMinAdjustT + it "updateMin/delete" $ run unary0 updateMinDeleteT + it "updateMinWithKey/adjust" $ run unary0 updateMinWithKeyAdjustT + it "updateMinWithKey/delete" $ run unary0 updateMinWithKeyDeleteT + it "minView" $ run unary0 minViewT + + describe "Max" $ do + it "lookupMax" $ run unary0 lookupMaxT + it "lookupMaxWithKey" $ run unary0 lookupMaxWithKeyT + it "adjustMax" $ run unary0 adjustMaxT + it "adjustMaxWithKey" $ run unary0 adjustMaxWithKeyT + it "deleteMax" $ run unary0 deleteMaxT + it "updateMax/adjust" $ run unary0 updateMaxAdjustT + it "updateMax/delete" $ run unary0 updateMaxDeleteT + it "updateMaxWithKey/adjust" $ run unary0 updateMaxWithKeyAdjustT + it "updateMaxWithKey/delete" $ run unary0 updateMaxWithKeyDeleteT + it "maxView" $ run unary0 maxViewT + + describe "Partition" $ do + it "filter" $ run unary0 filterT + it "filterWithKey" $ run unary0 filterWithKeyT + it "mapMaybe" $ run unary0 mapMaybeT + it "mapMaybeWithKey" $ run unary0 mapMaybeWithKeyT + it "partition" $ run unary0 partitionT + it "partitionWithKey" $ run unary0 partitionWithKeyT + it "mapEither" $ run unary0 mapEitherT + it "mapEitherWithKey" $ run unary0 mapEitherWithKeyT + + describe "Full-tree" $ do + it "(==)" $ run (equal <> binaryL) eqT + it "map" $ run unary0 mapT + it "mapWithKey" $ run unary0 mapWithKeyT + it "size" $ run unary0 sizeT + it "foldl" $ run unary0 foldlT + it "foldl'" $ run unary0 foldlT' + it "foldlWithKey" $ run unary0 foldlWithKeyT + it "foldlWithKey'" $ run unary0 foldlWithKeyT' + it "foldr" $ run unary0 foldrT + it "foldr'" $ run unary0 foldrT' + it "foldrWithKey" $ run unary0 foldrWithKeyT + it "foldrWithKey'" $ run unary0 foldrWithKeyT' + it "foldMap" $ run unary0 foldMapT + it "foldMapWithKey" $ run unary0 foldMapWithKeyT + it "traverse" $ run unary0 traverseT + it "traverseWithKey" $ run unary0 traverseWithKeyT + + describe "Merge" $ do + it "union" $ run binary unionT + it "unionL" $ run binaryL unionLT + it "unionWith" $ run binaryL unionWithT + it "unionWithKey" $ run binaryL unionWithKeyT + it "difference" $ run binaryL differenceT + it "differenceWith" $ run binaryL differenceWithT + it "differenceWithKey" $ run binaryL differenceWithKeyT + it "disjoint/yes" $ run binary disjointT + it "disjoint/no" $ run binaryL disjointT + it "intersection" $ run binary intersectionT + it "intersectionL" $ run binaryL intersectionLT + it "intersectionWith" $ run binaryL intersectionWithT + it "intersectionWithKey" $ run binaryL intersectionWithKeyT + it "compare/subset" $ run subset compareT + it "compare/superset" $ run superset compareT + it "compare/equal" $ run equal compareT + it "compare/incomparable" $ run binary compareT + it "merge/union" $ run binaryL mergeUnionT + it "merge/difference" $ run binaryL mergeDifferenceT + it "merge/intersection" $ run binaryL mergeIntersectionT diff --git a/test/properties/Test/Patricia/Word/Sample.hs b/test/properties/Test/Patricia/Word/Sample.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/Patricia/Word/Sample.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.Patricia.Word.Sample + ( Sample + , zero + , one + , tiny + , small + , medium + , large + + , mkUnary0 + , mkUnary1 + , mkUnary2 + + , mkBinary + , mkBinaryL + + , mkEqual + , mkSuperset + , mkSubset + ) where + +import No.Tree (NoTree) +import qualified No.Tree as No +import Test.Kit +import Test.Random + +import qualified Data.List as List +import System.Random + + + +data Sample = Sample + [(Word, Int)] -- ^ Keys in the dictionary + [(Word, Int)] -- ^ Keys not in the dictionary + deriving Show + +zero, one :: Sample +zero = Sample [] [(4507, 1), (5824, 2), (6183, 3), (6858, 4)] +one = Sample [(6593, 0)] + [(4905, 1), (6285, 2), (6134, 3), (6737, 4), (6928, 5), (7513, 6)] + + + +halve :: [a] -> ([a], [a]) +halve (a:b:cs) = let ~(xs, ys) = halve cs + in (a:xs, b:ys) +halve a = (a, []) + +sample :: (Word, Word) -> Int -> StdGen -> Sample +sample r n g = + let ~(xs, _) = list (uniformR r) n g + + ~(ys, zs) = halve $ zip (List.nub xs) [0..] + + in Sample ys zs + +tiny, small, medium, large :: Sample +tiny = sample (0x1000, 0x80000) 8 (mkStdGen 0) +small = sample (0x1000, 0x80000) 64 (mkStdGen 1) +medium = sample (0x1000, 0x80000) 512 (mkStdGen 2) +large = sample (0x1000, 0x80000) 4096 (mkStdGen 3) + + + +type FromList pat = forall x. [(Word, x)] -> pat x + +mkUnary0 :: FromList pat -> Sample -> [Case () (pat Int) (NoTree Word Int)] +mkUnary0 patFromList (Sample xs _) = [Case () (patFromList xs) (No.fromList xs)] + +mkUnary1 :: FromList pat -> Sample -> [Case (Word, Int) (pat Int) (NoTree Word Int)] +mkUnary1 patFromList (Sample xs ys) = + let pat = patFromList xs + no = No.fromList xs + + in foldr (\x -> (:) (Case x pat no)) [] $ xs <> ys + +mkUnary2 + :: FromList pat -> Sample -> [Case (Word, Word, Int) (pat Int) (NoTree Word Int)] +mkUnary2 patFromList (Sample xs ys) = + let pat = patFromList xs + no = No.fromList xs + + ~(as, bs) = halve xs + ~(cs, ds) = halve ys + + ones = fmap (\(a, i) -> (a, a, i)) $ as <> cs + + twos = zipWith (\(a, i) (b, _) -> (a, b, i)) bs ds + + in foldr (\x -> (:) (Case x pat no)) [] $ ones <> twos + + +mkBinary + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)] +mkBinary patFromList (Sample xs ys) = + [Case (patFromList ys, No.fromList ys) (patFromList xs) (No.fromList xs)] + +mkBinaryL + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)] +mkBinaryL patFromList (Sample xs ys) = + let ~(as, _) = halve xs + ~(bs, _) = halve ys + + ls = fmap (\(k, a) -> (k, negate a)) bs <> xs + rs = fmap (\(k, a) -> (k, negate a)) as <> ys + + in [Case (patFromList rs, No.fromList rs) (patFromList ls) (No.fromList ls)] + + +mkEqual + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)] +mkEqual patFromList (Sample xs _) = + let pat = patFromList xs + no = No.fromList xs + + in [Case (pat, no) pat no] + +mkSuperset + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)] +mkSuperset patFromList (Sample xs ys) = + let zs = xs <> ys + in [Case (patFromList zs, No.fromList zs) (patFromList xs) (No.fromList xs)] + +mkSubset + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree Word Int) (pat Int) (NoTree Word Int)] +mkSubset patFromList (Sample xs ys) = + let zs = xs <> ys + in [Case (patFromList xs, No.fromList xs) (patFromList zs) (No.fromList zs)] diff --git a/test/properties/Test/Patricia/Word/Strict.hs b/test/properties/Test/Patricia/Word/Strict.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/Patricia/Word/Strict.hs @@ -0,0 +1,907 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.Patricia.Word.Strict + ( test + ) where + +import Data.Patricia.Word.Strict (Patricia) +import qualified Data.Patricia.Word.Strict as Pat +import Data.Patricia.Word.Strict.Debug (validate, Validity (..)) +import qualified Data.Patricia.Word.Strict.Unsafe as Pat +import No.Tree (NoTree) +import qualified No.Tree as No +import Test.Patricia.Word.Sample +import Test.Kit + +import Data.Functor.Identity +import Test.Hspec + + + +patFromList :: [(Word, a)] -> Patricia a +patFromList = foldr (\(k, a) p -> Pat.insert k a p) Pat.empty + +patToList :: Patricia a -> [(Word, a)] +patToList = Pat.foldrWithKey (\k a -> (:) (k, a)) [] + + + +patRange :: (Pat.Range -> a -> b) -> (Word, Word, a) -> b +patRange f (k1, k2, a) = f (Pat.Range k1 k2) a + +patRange_ :: (Pat.Range -> b) -> (Word, Word) -> b +patRange_ f (k1, k2) = f (Pat.Range k1 k2) + +noRange :: (No.Range Word -> a -> b) -> (Word, Word, a) -> b +noRange f (k1, k2, a) = f (No.WordRange No.Closed k1 No.Closed k2) a + +noRange_ :: (No.Range Word -> b) -> (Word, Word) -> b +noRange_ f (k1, k2) = f (No.WordRange No.Closed k1 No.Closed k2) + + + +unary0 :: [Case () (Patricia Int) (NoTree Word Int)] +unary0 = foldMap (mkUnary0 patFromList) [zero, one, tiny, small, medium] -- , large] + +unary1 :: [Case (Word, Int) (Patricia Int) (NoTree Word Int)] +unary1 = foldMap (mkUnary1 patFromList) [zero, one, tiny, small, medium] -- , large] + +unary1_ :: [Case Word (Patricia Int) (NoTree Word Int)] +unary1_ = augment fst unary1 + +unary2 :: [Case (Word, Word, Int) (Patricia Int) (NoTree Word Int)] +unary2 = foldMap (mkUnary2 patFromList) [zero, one, tiny, small, medium] -- , large] + +unary2_ :: [Case (Word, Word) (Patricia Int) (NoTree Word Int)] +unary2_ = augment (\(k1, k2, _) -> (k1, k2)) unary2 + +binary + , binaryL + , subset + , superset + , equal + :: [Case (Patricia Int, NoTree Word Int) (Patricia Int) (NoTree Word Int)] +binary = foldMap (mkBinary patFromList) [zero, one, tiny, small, medium] -- , large] +binaryL = foldMap (mkBinaryL patFromList) [zero, one, tiny, small, medium] -- , large] +subset = foldMap (mkSubset patFromList) [zero, one, tiny, small, medium] -- , large] +superset = foldMap (mkSuperset patFromList) [zero, one, tiny, small, medium] -- , large] +equal = foldMap (mkEqual patFromList) [zero, one, tiny, small, medium] -- , large] + + + +type IdT s a b = Test s (Patricia a) (NoTree Word a) b b + +type TreeT s a = Test s (Patricia a) (NoTree Word a) (Patricia a) (NoTree Word a) + +treeEq :: Eq a => Patricia a -> NoTree Word a -> Bool +treeEq pat no = + case validate pat of + Valid -> patToList pat == No.toList no + _ -> False + +type SplitT s a = + Test s (Patricia a) (NoTree Word a) + (Pat.Split a a) (NoTree Word a, NoTree Word a) + +splitEq + :: Eq a => Pat.Split a a -> (NoTree Word a, NoTree Word a) -> Bool +splitEq (Pat.Split a b) (x, y) = treeEq a x && treeEq b y + +type SplitLookupT s a = + Test s (Patricia a) (NoTree Word a) + (Pat.SplitLookup a a a) (NoTree Word a, Maybe a, NoTree Word a) + +splitLookupEq + :: Eq a + => Pat.SplitLookup a a a -> (NoTree Word a, Maybe a, NoTree Word a) -> Bool +splitLookupEq (Pat.SplitLookup a b c) (x, y, z) = treeEq a x && b == y && treeEq c z + +type LookupT s a = + Test s (Patricia a) (NoTree Word a) (Maybe (Pat.Lookup a)) (Maybe (Word, a)) + +lookupEq :: Eq a => Maybe (Pat.Lookup a) -> Maybe (Word, a) -> Bool +lookupEq (Just (Pat.Lookup k a)) (Just (l, b)) = k == l && a == b +lookupEq Nothing Nothing = True +lookupEq _ _ = False + +type MinViewT s a = + Test s (Patricia a) (NoTree Word a) + (Maybe (Pat.ViewL a)) (Maybe (Word, a, NoTree Word a)) + +minViewEq :: Eq a => Maybe (Pat.ViewL a) -> Maybe (Word, a, NoTree Word a) -> Bool +minViewEq (Just (Pat.ViewL (Pat.Lookup k a) pat)) (Just (l, b, no)) = + k == l && a == b && treeEq pat no + +minViewEq Nothing Nothing = True +minViewEq _ _ = False + +type MaxViewT s a = + Test s (Patricia a) (NoTree Word a) + (Maybe (Pat.ViewR a)) (Maybe (NoTree Word a, Word, a)) + +maxViewEq :: Eq a => Maybe (Pat.ViewR a) -> Maybe (NoTree Word a, Word, a) -> Bool +maxViewEq (Just (Pat.ViewR pat (Pat.Lookup k a))) (Just (no, l, b)) = + k == l && a == b && treeEq pat no + +maxViewEq Nothing Nothing = True +maxViewEq _ _ = False + + + +lookupT, dirtyLookupT :: Eq a => IdT Word a (Maybe a) +lookupT = lookupT_ Pat.lookup +dirtyLookupT = lookupT_ Pat.dirtyLookup + +lookupT_ :: Eq a => (forall x. Word -> Patricia x -> Maybe x) -> IdT Word a (Maybe a) +lookupT_ f = Test (==) f No.lookup + +findT, dirtyFindT :: Eq a => IdT (Word, a) a a +findT = findT_ Pat.find +dirtyFindT = findT_ Pat.dirtyFind + +findT_ :: Eq a => (forall x. x -> Word -> Patricia x -> x) -> IdT (Word, a) a a +findT_ f = Test (==) (\(k, a) -> f a k) (\(k, a) -> No.find a k) + +memberT, dirtyMemberT :: IdT Word a Bool +memberT = memberT_ Pat.member +dirtyMemberT = memberT_ Pat.dirtyMember + +memberT_ :: (forall x. Word -> Patricia x -> Bool) -> IdT Word a Bool +memberT_ f = Test (==) f No.member + + + +insertT :: Eq a => TreeT (Word, a) a +insertT = Test treeEq (uncurry Pat.insert) (uncurry No.insert) + +insertWithT, insertWithT' :: (Eq a, Integral a) => TreeT (Word, a) a +insertWithT = insertWithT_ Pat.insertWith +insertWithT' = insertWithT_ Pat.insertWith' + +insertWithT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Word -> x -> Patricia x -> Patricia x) -> TreeT (Word, a) a +insertWithT_ g = + let f x = (+ fromIntegral x) + in Test treeEq (\(k, a) -> g (f a) k a) (\(k, a) -> No.insertWith (f a) k a) + +adjustT, adjustT' :: (Eq a, Integral a) => TreeT (Word, a) a +adjustT = adjustT_ Pat.adjust +adjustT' = adjustT_ Pat.adjust' + +adjustT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Word -> Patricia x -> Patricia x) -> TreeT (Word, a) a +adjustT_ g = + let f a = (+ fromIntegral a) + in Test treeEq (\(k, a) -> g (f a) k) (\(k, a) -> No.adjust (f a) k) + +deleteT :: Eq a => TreeT Word a +deleteT = Test treeEq Pat.delete No.delete + +updateAdjustT, updateDeleteT :: (Eq a, Integral a) => TreeT (Word, a) a +updateAdjustT = updateT_ (\a -> Just . (+ a)) +updateDeleteT = updateT_ (\_ _ -> Nothing) + +updateT_ :: Eq a => (a -> a -> Maybe a) -> TreeT (Word, a) a +updateT_ f = Test treeEq (\(k, a) -> Pat.update (f a) k) (\(k, a) -> No.update (f a) k) + +alterInsertT + , alterInsertWithT + , alterAdjustT + , alterDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +alterInsertT = alterT_ (\a _ -> Just a) +alterInsertWithT = alterT_ (\a -> Just . maybe a (+ a)) +alterAdjustT = alterT_ (\a -> fmap (+ a)) +alterDeleteT = alterT_ (\_ _ -> Nothing) + +alterT_ :: Eq a => (a -> Maybe a -> Maybe a) -> TreeT (Word, a) a +alterT_ f = Test treeEq (\(k, a) -> Pat.alter (f a) k) (\(k, a) -> No.alter (f a) k) + + + +splitLT :: Eq a => SplitT Word a +splitLT = Test splitEq Pat.splitL (No.splitL No.Closed) + +splitRT :: Eq a => SplitT Word a +splitRT = Test splitEq Pat.splitR No.splitR + +splitLookupT :: Eq a => SplitLookupT Word a +splitLookupT = Test splitLookupEq Pat.splitLookup No.splitLookup + + + +lookupLT :: Eq a => LookupT Word a +lookupLT = Test lookupEq Pat.lookupL (No.lookupL No.Closed) + +adjustLT, adjustLT' :: (Eq a, Integral a) => TreeT (Word, a) a +adjustLT = adjustLT_ Pat.adjustL +adjustLT' = adjustLT_ Pat.adjustL' + +adjustLT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Word -> Patricia x -> Patricia x) + -> TreeT (Word, a) a +adjustLT_ g = + let f a = (+ a) + in Test treeEq (\(k, a) -> g (f a) k) (\(k, a) -> No.adjustL (f a) No.Closed k) + +adjustLWithKeyT + , adjustLWithKeyT' + :: (Eq a, Integral a) => TreeT (Word, a) a +adjustLWithKeyT = adjustLWithKeyT_ Pat.adjustLWithKey +adjustLWithKeyT' = adjustLWithKeyT_ Pat.adjustLWithKey' + +adjustLWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Word -> x -> x) -> Word -> Patricia x -> Patricia x) + -> TreeT (Word, a) a +adjustLWithKeyT_ g = + let f a k = (+ fromIntegral k) . (+ a) + in Test treeEq (\(k, a) -> g (f a) k) (\(k, a) -> No.adjustLWithKey (f a) No.Closed k) + +deleteLT :: Eq a => TreeT (Word) a +deleteLT = Test treeEq Pat.deleteL (No.deleteL No.Closed) + +updateLAdjustT + , updateLDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +updateLAdjustT = updateLT_ (\a -> Just . (+ a)) +updateLDeleteT = updateLT_ (\_ _ -> Nothing) + +updateLT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (Word, a) a +updateLT_ f = + Test treeEq (\(k, a) -> Pat.updateL (f a) k) (\(k, a) -> No.updateL (f a) No.Closed k) + +updateLWithKeyAdjustT + , updateLWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +updateLWithKeyAdjustT = updateLWithKeyT_ (\a k -> Just . (+ fromIntegral k) . (+ a)) +updateLWithKeyDeleteT = updateLWithKeyT_ (\_ _ _ -> Nothing) + +updateLWithKeyT_ + :: (Eq a, Integral a) + => (a -> Word -> a -> Maybe a) -> TreeT (Word, a) a +updateLWithKeyT_ f = + Test treeEq (\(k, a) -> Pat.updateLWithKey (f a) k) + (\(k, a) -> No.updateLWithKey (f a) No.Closed k) + +takeLT :: Eq a => TreeT (Word) a +takeLT = Test treeEq Pat.takeL (No.takeL No.Closed) + + + +lookupRT :: Eq a => LookupT (Word) a +lookupRT = Test lookupEq Pat.lookupR (No.lookupR No.Closed) + +adjustRT, adjustRT' :: (Eq a, Integral a) => TreeT (Word, a) a +adjustRT = adjustRT_ Pat.adjustR +adjustRT' = adjustRT_ Pat.adjustR' + +adjustRT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Word -> Patricia x -> Patricia x) + -> TreeT (Word, a) a +adjustRT_ g = + let f a = (+ a) + in Test treeEq (\(k, a) -> g (f a) k) (\(k, a) -> No.adjustR (f a) No.Closed k) + +adjustRWithKeyT + , adjustRWithKeyT' + :: (Eq a, Integral a) => TreeT (Word, a) a +adjustRWithKeyT = adjustRWithKeyT_ Pat.adjustRWithKey +adjustRWithKeyT' = adjustRWithKeyT_ Pat.adjustRWithKey' + +adjustRWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Word -> x -> x) -> Word -> Patricia x -> Patricia x) + -> TreeT (Word, a) a +adjustRWithKeyT_ g = + let f a k = (+ fromIntegral k) . (+ a) + in Test treeEq (\(k, a) -> g (f a) k) (\(k, a) -> No.adjustRWithKey (f a) No.Closed k) + +deleteRT :: Eq a => TreeT (Word) a +deleteRT = Test treeEq Pat.deleteR (No.deleteR No.Closed) + +updateRAdjustT + , updateRDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +updateRAdjustT = updateRT_ (\a -> Just . (+ a)) +updateRDeleteT = updateRT_ (\_ _ -> Nothing) + +updateRT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (Word, a) a +updateRT_ f = + Test treeEq (\(k, a) -> Pat.updateR (f a) k) (\(k, a) -> No.updateR (f a) No.Closed k) + +updateRWithKeyAdjustT + , updateRWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (Word, a) a +updateRWithKeyAdjustT = updateRWithKeyT_ (\a k -> Just . (+ fromIntegral k) . (+ a)) +updateRWithKeyDeleteT = updateRWithKeyT_ (\_ _ _ -> Nothing) + +updateRWithKeyT_ + :: (Eq a, Integral a) + => (a -> Word -> a -> Maybe a) -> TreeT (Word, a) a +updateRWithKeyT_ f = + Test treeEq (\(k, a) -> Pat.updateRWithKey (f a) k) + (\(k, a) -> No.updateRWithKey (f a) No.Closed k) + +takeRT :: Eq a => TreeT (Word) a +takeRT = Test treeEq Pat.takeR (No.takeR No.Closed) + + + +adjustRangeT + , adjustRangeT' + :: (Eq a, Integral a) => TreeT (Word, Word, a) a +adjustRangeT = adjustRangeT_ Pat.adjustRange +adjustRangeT' = adjustRangeT_ Pat.adjustRange' + +adjustRangeT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Pat.Range -> Patricia x -> Patricia x) + -> TreeT (Word, Word, a) a +adjustRangeT_ g = + let f a = (+ a) + in Test treeEq (patRange $ \r a -> g (f a) r) (noRange $ \r a -> No.adjustRange (f a) r) + +adjustRangeWithKeyT + , adjustRangeWithKeyT' + :: (Eq a, Integral a) => TreeT (Word, Word, a) a +adjustRangeWithKeyT = adjustRangeWithKeyT_ Pat.adjustRangeWithKey +adjustRangeWithKeyT' = adjustRangeWithKeyT_ Pat.adjustRangeWithKey' + +adjustRangeWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Word -> x -> x) -> Pat.Range -> Patricia x -> Patricia x) + -> TreeT (Word, Word, a) a +adjustRangeWithKeyT_ g = + let f a k = (+ fromIntegral k) . (+ a) + in Test treeEq + (patRange $ \r a -> g (f a) r) (noRange $ \r a -> No.adjustRangeWithKey (f a) r) + +deleteRangeT :: Eq a => TreeT (Word, Word) a +deleteRangeT = Test treeEq (patRange_ Pat.deleteRange) (noRange_ No.deleteRange) + +updateRangeAdjustT + , updateRangeDeleteT + :: (Eq a, Integral a) => TreeT (Word, Word, a) a +updateRangeAdjustT = updateRangeT_ (\a -> Just . (+ a)) +updateRangeDeleteT = updateRangeT_ (\_ _ -> Nothing) + +updateRangeT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (Word, Word, a) a +updateRangeT_ f = + Test treeEq + (patRange $ \r a -> Pat.updateRange (f a) r) (noRange $ \r a -> No.updateRange (f a) r) + +updateRangeWithKeyAdjustT + , updateRangeWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (Word, Word, a) a +updateRangeWithKeyAdjustT = updateRangeWithKeyT_ (\a k -> Just . (+ fromIntegral k) . (+ a)) +updateRangeWithKeyDeleteT = updateRangeWithKeyT_ (\_ _ _ -> Nothing) + +updateRangeWithKeyT_ + :: (Eq a, Integral a) + => (a -> Word -> a -> Maybe a) -> TreeT (Word, Word, a) a +updateRangeWithKeyT_ f = + Test treeEq (patRange $ \r a -> Pat.updateRangeWithKey (f a) r) + (noRange $ \r a -> No.updateRangeWithKey (f a) r) + + + +takeRangeT :: Eq a => TreeT (Word, Word) a +takeRangeT = Test treeEq (patRange_ Pat.takeRange) (noRange_ No.takeRange) + + + +lookupMinT :: Eq a => IdT () a (Maybe a) +lookupMinT = Test (==) (\_ -> Pat.lookupMin) (\_ -> No.lookupMin) + +lookupMinWithKeyT :: Eq a => LookupT () a +lookupMinWithKeyT = Test lookupEq (\_ -> Pat.lookupMinWithKey) (\_ -> No.lookupMinWithKey) + +adjustMinT, adjustMinT' :: (Eq a, Integral a) => TreeT () a +adjustMinT = adjustMinT_ Pat.adjustMin +adjustMinT' = adjustMinT_ Pat.adjustMin' + +adjustMinT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Patricia x -> Patricia x) -> TreeT () a +adjustMinT_ f = Test treeEq (\_ -> f (+ 10000)) (\_ -> No.adjustMin (+ 10000)) + +adjustMinWithKeyT, adjustMinWithKeyT' :: (Eq a, Integral a) => TreeT () a +adjustMinWithKeyT = adjustMinWithKeyT_ Pat.adjustMinWithKey +adjustMinWithKeyT' = adjustMinWithKeyT_ Pat.adjustMinWithKey' + +adjustMinWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Word -> x -> x) -> Patricia x -> Patricia x) -> TreeT () a +adjustMinWithKeyT_ g = + let f k = (+ fromIntegral k) + in Test treeEq (\_ -> g f) (\_ -> No.adjustMinWithKey f) + +deleteMinT :: (Eq a, Integral a) => TreeT () a +deleteMinT = Test treeEq (\_ -> Pat.deleteMin) (\_ -> No.deleteMin) + +updateMinAdjustT, updateMinDeleteT :: (Eq a, Integral a) => TreeT () a +updateMinAdjustT = updateMinT_ (Just . (+ 10000)) +updateMinDeleteT = updateMinT_ (\_ -> Nothing) + +updateMinT_ :: (Eq a, Integral a) => (a -> Maybe a) -> TreeT () a +updateMinT_ f = Test treeEq (\_ -> Pat.updateMin f) (\_ -> No.updateMin f) + +updateMinWithKeyAdjustT, updateMinWithKeyDeleteT :: (Eq a, Integral a) => TreeT () a +updateMinWithKeyAdjustT = updateMinWithKeyT_ (\k -> Just . (+ fromIntegral k)) +updateMinWithKeyDeleteT = updateMinWithKeyT_ (\_ _ -> Nothing) + +updateMinWithKeyT_ :: (Eq a, Integral a) => (Word -> a -> Maybe a) -> TreeT () a +updateMinWithKeyT_ f = + Test treeEq (\_ -> Pat.updateMinWithKey f) (\_ -> No.updateMinWithKey f) + +minViewT :: Eq a => MinViewT () a +minViewT = Test minViewEq (\_ -> Pat.minView) (\_ -> No.minView) + + + +lookupMaxT :: Eq a => IdT () a (Maybe a) +lookupMaxT = Test (==) (\_ -> Pat.lookupMax) (\_ -> No.lookupMax) + +lookupMaxWithKeyT :: Eq a => LookupT () a +lookupMaxWithKeyT = Test lookupEq (\_ -> Pat.lookupMaxWithKey) (\_ -> No.lookupMaxWithKey) + +adjustMaxT, adjustMaxT' :: (Eq a, Integral a) => TreeT () a +adjustMaxT = adjustMaxT_ Pat.adjustMax +adjustMaxT' = adjustMaxT_ Pat.adjustMax' + +adjustMaxT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Patricia x -> Patricia x) -> TreeT () a +adjustMaxT_ f = Test treeEq (\_ -> f (+ 10000)) (\_ -> No.adjustMax (+ 10000)) + +adjustMaxWithKeyT, adjustMaxWithKeyT' :: (Eq a, Integral a) => TreeT () a +adjustMaxWithKeyT = adjustMaxWithKeyT_ Pat.adjustMaxWithKey +adjustMaxWithKeyT' = adjustMaxWithKeyT_ Pat.adjustMaxWithKey' + +adjustMaxWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Word -> x -> x) -> Patricia x -> Patricia x) -> TreeT () a +adjustMaxWithKeyT_ g = + let f k = (+ fromIntegral k) + in Test treeEq (\_ -> g f) (\_ -> No.adjustMaxWithKey f) + +deleteMaxT :: (Eq a, Integral a) => TreeT () a +deleteMaxT = Test treeEq (\_ -> Pat.deleteMax) (\_ -> No.deleteMax) + +updateMaxAdjustT, updateMaxDeleteT :: (Eq a, Integral a) => TreeT () a +updateMaxAdjustT = updateMaxT_ (Just . (+ 10000)) +updateMaxDeleteT = updateMaxT_ (\_ -> Nothing) + +updateMaxT_ :: (Eq a, Integral a) => (a -> Maybe a) -> TreeT () a +updateMaxT_ f = Test treeEq (\_ -> Pat.updateMax f) (\_ -> No.updateMax f) + +updateMaxWithKeyAdjustT, updateMaxWithKeyDeleteT :: (Eq a, Integral a) => TreeT () a +updateMaxWithKeyAdjustT = updateMaxWithKeyT_ (\k -> Just . (+ fromIntegral k)) +updateMaxWithKeyDeleteT = updateMaxWithKeyT_ (\_ _ -> Nothing) + +updateMaxWithKeyT_ :: (Eq a, Integral a) => (Word -> a -> Maybe a) -> TreeT () a +updateMaxWithKeyT_ f = + Test treeEq (\_ -> Pat.updateMaxWithKey f) (\_ -> No.updateMaxWithKey f) + +maxViewT :: Eq a => MaxViewT () a +maxViewT = Test maxViewEq (\_ -> Pat.maxView) (\_ -> No.maxView) + + + +eqT :: (Eq a, Integral a) => IdT (Pat.Patricia a, No.NoTree Word a) a Bool +eqT = Test (==) (\(a, _) b -> a == b) (\(_, a) b -> a == b) + +filterT :: (Eq a, Integral a) => TreeT () a +filterT = Test treeEq (\_ -> Pat.filter odd) (\_ -> No.filter odd) + +filterWithKeyT :: (Eq a, Integral a) => TreeT () a +filterWithKeyT = + let f k a = odd $ fromIntegral k + a + in Test treeEq (\_ -> Pat.filterWithKey f) (\_ -> No.filterWithKey f) + +mapMaybeT :: (Eq a, Integral a) => TreeT () a +mapMaybeT = + let f a | odd a = Nothing + | otherwise = Just a + + in Test treeEq (\_ -> Pat.mapMaybe f) (\_ -> No.mapMaybe f) + +mapMaybeWithKeyT :: (Eq a, Integral a) => TreeT () a +mapMaybeWithKeyT = + let f k a | odd (fromIntegral k + a) = Nothing + | otherwise = Just a + + in Test treeEq (\_ -> Pat.mapMaybeWithKey f) (\_ -> No.mapMaybeWithKey f) + +partitionT :: (Eq a, Integral a) => SplitT () a +partitionT = Test splitEq (\_ -> Pat.partition odd) (\_ -> No.partition odd) + +partitionWithKeyT :: (Eq a, Integral a) => SplitT () a +partitionWithKeyT = + let f k a = odd $ fromIntegral k + a + in Test splitEq (\_ -> Pat.partitionWithKey f) (\_ -> No.partitionWithKey f) + +mapEitherT :: (Eq a, Integral a) => SplitT () a +mapEitherT = + let f a | odd a = Left a + | otherwise = Right a + + in Test splitEq (\_ -> Pat.mapEither f) (\_ -> No.mapEither f) + +mapEitherWithKeyT :: (Eq a, Integral a) => SplitT () a +mapEitherWithKeyT = + let f k a | odd (fromIntegral k + a) = Left a + | otherwise = Right a + + in Test splitEq (\_ -> Pat.mapEitherWithKey f) (\_ -> No.mapEitherWithKey f) + + + +mapT, mapT' :: (Eq a, Num a) => TreeT () a +mapT = mapT_ Pat.map +mapT' = mapT_ Pat.map' + +mapT_ :: (Eq a, Num a) => (forall x. (x -> x) -> Patricia x -> Patricia x) -> TreeT () a +mapT_ g = + let f = (+ 10000) + in Test treeEq (\_ -> g f) (\_ -> No.map f) + +mapWithKeyT, mapWithKeyT' :: (Eq a, Num a) => TreeT () a +mapWithKeyT = mapWithKeyT_ Pat.mapWithKey +mapWithKeyT' = mapWithKeyT_ Pat.mapWithKey' + +mapWithKeyT_ + :: (Eq a, Num a) + => (forall x. (Word -> x -> x) -> Patricia x -> Patricia x) -> TreeT () a +mapWithKeyT_ g = + let f k = (+ fromIntegral k) . (+ 10000) + in Test treeEq (\_ -> g f) (\_ -> No.mapWithKey f) + + + +sizeT :: IdT () a Int +sizeT = Test (==) (\_ -> Pat.size) (\_ -> No.size) + +foldlT, foldlT' :: Eq a => IdT () a [a] +foldlT = foldlT_ Pat.foldl +foldlT' = foldlT_ Pat.foldl' + +foldlT_ :: Eq a => (forall x. (x -> a -> x) -> x -> Patricia a -> x) -> IdT () a [a] +foldlT_ g = Test (==) (\_ -> g (flip (:)) []) (\_ -> No.foldl (flip (:)) []) + +foldlWithKeyT, foldlWithKeyT' :: Eq a => IdT () a [(Word, a)] +foldlWithKeyT = foldlWithKeyT_ Pat.foldlWithKey +foldlWithKeyT' = foldlWithKeyT_ Pat.foldlWithKey' + +foldlWithKeyT_ + :: Eq a + => (forall x. (x -> Word -> a -> x) -> x -> Patricia a -> x) -> IdT () a [(Word, a)] +foldlWithKeyT_ g = + let f z k a = (k, a) : z + in Test (==) (\_ -> g f []) (\_ -> No.foldlWithKey f []) + + + +foldrT, foldrT' :: Eq a => IdT () a [a] +foldrT = foldrT_ Pat.foldr +foldrT' = foldrT_ Pat.foldr' + +foldrT_ + :: Eq a => (forall x. (a -> x -> x) -> x -> Patricia a -> x) -> IdT () a [a] +foldrT_ g = Test (==) (\_ -> g (:) []) (\_ -> No.foldr (:) []) + +foldrWithKeyT, foldrWithKeyT' :: Eq a => IdT () a [(Word, a)] +foldrWithKeyT = foldrWithKeyT_ Pat.foldrWithKey +foldrWithKeyT' = foldrWithKeyT_ Pat.foldrWithKey' + +foldrWithKeyT_ + :: Eq a + => (forall x. (Word -> a -> x -> x) -> x -> Patricia a -> x) -> IdT () a [(Word, a)] +foldrWithKeyT_ g = + let f k a = (:) (k, a) + in Test (==) (\_ -> g f []) (\_ -> No.foldrWithKey f []) + + + +foldMapT :: Eq a => IdT () a [a] +foldMapT = Test (==) (\_ -> Pat.foldMap pure) (\_ -> No.foldMap pure) + +foldMapWithKeyT :: Eq a => IdT () a [(Word, a)] +foldMapWithKeyT = + let f k a = [(k, a)] + in Test (==) (\_ -> Pat.foldMapWithKey f) (\_ -> No.foldMapWithKey f) + + + +idTreeEq :: Eq a => Identity (Patricia a) -> Identity (NoTree Word a) -> Bool +idTreeEq (Identity a) (Identity b) = treeEq a b + +traverseT + :: (Eq a, Num a) + => Test s (Patricia a) (NoTree Word a) (Identity (Patricia a)) (Identity (NoTree Word a)) +traverseT = + let f = Identity . (+ 10000) + in Test idTreeEq (\_ -> Pat.traverse f) (\_ -> No.traverse f) + +traverseWithKeyT + :: (Eq a, Num a) + => Test s (Patricia a) (NoTree Word a) (Identity (Patricia a)) (Identity (NoTree Word a)) +traverseWithKeyT = + let f k a = Identity $ fromIntegral k + 10000 + a + in Test idTreeEq (\_ -> Pat.traverseWithKey f) (\_ -> No.traverseWithKey f) + + + +unionT :: Eq a => TreeT (Patricia a, NoTree Word a) a +unionT = Test treeEq (\(a, _) b -> Pat.union a b) (\(_, a) b -> No.unionL a b) + +unionLT :: Eq a => TreeT (Patricia a, NoTree Word a) a +unionLT = Test treeEq (\(a, _) b -> Pat.unionL a b) (\(_, a) b -> No.unionL a b) + +unionWithT' :: (Eq a, Num a) => TreeT (Patricia a, NoTree Word a) a +unionWithT' = Test treeEq (\(a, _) b -> Pat.unionWith' (+) a b) + (\(_, a) b -> No.unionWithKey (\_ -> (+)) a b) + +unionWithKeyT' + , mergeUnionT + :: (Eq a, Num a) => TreeT (Patricia a, NoTree Word a) a +unionWithKeyT' = unionWithKeyT_ Pat.unionWithKey' +mergeUnionT = + unionWithKeyT_ $ \f -> + Pat.merge + (\k a b -> Pat.Tip k $ f k a b) + Pat.Tip Pat.Bin Pat.Tip Pat.Bin + +unionWithKeyT_ + :: (Eq a, Num a) + => (forall x. (Word -> x -> x -> x) -> Patricia x -> Patricia x -> Patricia x) + -> TreeT (Patricia a, NoTree Word a) a +unionWithKeyT_ g = + let f k a b = fromIntegral k + a + b + in Test treeEq (\(a, _) b -> g f a b) + (\(_, a) b -> No.unionWithKey f a b) + + + +differenceT :: Eq a => TreeT (Patricia a, NoTree Word a) a +differenceT = Test treeEq (\(a, _) b -> Pat.difference a b) + (\(_, a) b -> No.difference a b) + +differenceWithT :: (Eq a, Integral a) => TreeT (Patricia a, NoTree Word a) a +differenceWithT = + let f a b = let c = a + b + in if odd c + then Nothing + else Just c + + in Test treeEq (\(a, _) b -> Pat.differenceWith f a b) + (\(_, a) b -> No.differenceWithKey (\_ -> f) a b) + +differenceWithKeyT + , mergeDifferenceT + :: (Eq a, Integral a) => TreeT (Patricia a, NoTree Word a) a +differenceWithKeyT = differenceWithKeyT_ Pat.differenceWithKey +mergeDifferenceT = + differenceWithKeyT_ $ \f -> + Pat.merge + (\k a b -> case f k a b of + Just c -> Pat.Tip k c + Nothing -> Pat.Nil + ) + Pat.Tip Pat.Bin + (\_ _ -> Pat.Nil) (\_ _ _ -> Pat.Nil) + +differenceWithKeyT_ + :: (Eq a, Integral a) + => (forall x y. (Word -> x -> y -> Maybe x) -> Patricia x -> Patricia y -> Patricia x) + -> TreeT (Patricia a, NoTree Word a) a +differenceWithKeyT_ g = + let f k a b = let c = fromIntegral k + a + b + in if odd c + then Nothing + else Just c + + in Test treeEq (\(a, _) b -> g f a b) + (\(_, a) b -> No.differenceWithKey f a b) + + + +disjointT :: IdT (Patricia a, NoTree Word a) a Bool +disjointT = Test (==) (\(a, _) b -> Pat.disjoint a b) + (\(_, a) b -> No.null $ No.intersectionL a b) + +intersectionT :: Eq a => TreeT (Patricia a, NoTree Word a) a +intersectionT = Test treeEq (\(a, _) b -> Pat.intersection a b) + (\(_, a) b -> No.intersectionL a b) + +intersectionLT :: Eq a => TreeT (Patricia a, NoTree Word a) a +intersectionLT = Test treeEq (\(a, _) b -> Pat.intersectionL a b) + (\(_, a) b -> No.intersectionL a b) + +intersectionWithT' :: (Eq a, Num a) => TreeT (Patricia a, NoTree Word a) a +intersectionWithT' = Test treeEq (\(a, _) b -> Pat.intersectionWith' (+) a b) + (\(_, a) b -> No.intersectionWithKey (\_ -> (+)) a b) + +intersectionWithKeyT' + , mergeIntersectionT + :: (Eq a, Num a) => TreeT (Patricia a, NoTree Word a) a +intersectionWithKeyT' = intersectionWithKeyT_ Pat.intersectionWithKey' +mergeIntersectionT = + intersectionWithKeyT_ $ \f -> + Pat.merge + (\k a b -> Pat.Tip k $ f k a b) + (\_ _ -> Pat.Nil) (\_ _ _ -> Pat.Nil) + (\_ _ -> Pat.Nil) (\_ _ _ -> Pat.Nil) + +intersectionWithKeyT_ + :: (Eq a, Num a) + => (forall x y z. (Word -> x -> y -> z) -> Patricia x -> Patricia y -> Patricia z) + -> TreeT (Patricia a, NoTree Word a) a +intersectionWithKeyT_ g = + let f k a b = fromIntegral k + a + b + in Test treeEq (\(a, _) b -> g f a b) + (\(_, a) b -> No.intersectionWithKey f a b) + + + +compareT :: Eq a => IdT (Patricia a, NoTree Word a) a Pat.PartialOrdering +compareT = Test (==) (\(a, _) b -> Pat.compare (==) a b) + (\(_, a) b -> No.compare a b) + + + +test :: Spec +test = do + describe "Single-key" $ do + it "lookup" $ run unary1_ lookupT + it "dirtyLookup" $ run unary1_ dirtyLookupT + it "find" $ run unary1 findT + it "dirtyFind" $ run unary1 dirtyFindT + it "member" $ run unary1_ memberT + it "dirtyMember" $ run unary1_ dirtyMemberT + it "insert" $ run unary1 insertT + it "insertWith" $ run unary1 insertWithT + it "insertWith'" $ run unary1 insertWithT' + it "adjust" $ run unary1 adjustT + it "adjust'" $ run unary1 adjustT' + it "delete" $ run unary1_ deleteT + it "update/adjust" $ run unary1 updateAdjustT + it "update/delete" $ run unary1 updateDeleteT + it "alter/insert" $ run unary1 alterInsertT + it "alter/insertWith" $ run unary1 alterInsertWithT + it "alter/adjust" $ run unary1 alterAdjustT + it "alter/delete" $ run unary1 alterDeleteT + + describe "Split" $ do + it "splitL" $ run unary1_ splitLT + it "splitR" $ run unary1_ splitRT + it "splitLookup" $ run unary1_ splitLookupT + + describe "Left" $ do + it "lookupL" $ run unary1_ lookupLT + it "adjustL" $ run unary1 adjustLT + it "adjustL'" $ run unary1 adjustLT' + it "adjustLWithKey" $ run unary1 adjustLWithKeyT + it "adjustLWithKey'" $ run unary1 adjustLWithKeyT' + it "deleteL" $ run unary1_ deleteLT + it "updateL/adjust" $ run unary1 updateLAdjustT + it "updateL/delete" $ run unary1 updateLDeleteT + it "updateLWithKey/adjust" $ run unary1 updateLWithKeyAdjustT + it "updateLWithKey/delete" $ run unary1 updateLWithKeyDeleteT + it "takeL" $ run unary1_ takeLT + + describe "Right" $ do + it "lookupR" $ run unary1_ lookupRT + it "adjustR" $ run unary1 adjustRT + it "adjustR'" $ run unary1 adjustRT' + it "adjustRWithKey" $ run unary1 adjustRWithKeyT + it "adjustRWithKey'" $ run unary1 adjustRWithKeyT' + it "deleteR" $ run unary1_ deleteRT + it "updateR/adjust" $ run unary1 updateRAdjustT + it "updateR/delete" $ run unary1 updateRDeleteT + it "updateRWithKey/adjust" $ run unary1 updateRWithKeyAdjustT + it "updateRWithKey/delete" $ run unary1 updateRWithKeyDeleteT + it "takeR" $ run unary1_ takeRT + + describe "Range" $ do + it "adjustRange" $ run unary2 adjustRangeT + it "adjustRange'" $ run unary2 adjustRangeT' + it "adjustRangeWithKey" $ run unary2 adjustRangeWithKeyT + it "adjustRangeWithKey'" $ run unary2 adjustRangeWithKeyT' + it "deleteRange" $ run unary2_ deleteRangeT + it "updateRange/adjust" $ run unary2 updateRangeAdjustT + it "updateRange/delete" $ run unary2 updateRangeDeleteT + it "updateRangeWithKey/adjust" $ run unary2 updateRangeWithKeyAdjustT + it "updateRangeWithKey/delete" $ run unary2 updateRangeWithKeyDeleteT + it "takeRange" $ run unary2_ takeRangeT + + describe "Min" $ do + it "lookupMin" $ run unary0 lookupMinT + it "lookupMinWithKey" $ run unary0 lookupMinWithKeyT + it "adjustMin" $ run unary0 adjustMinT + it "adjustMinWithKey" $ run unary0 adjustMinWithKeyT + it "adjustMin'" $ run unary0 adjustMinT' + it "adjustMinWithKey'" $ run unary0 adjustMinWithKeyT' + it "deleteMin" $ run unary0 deleteMinT + it "updateMin/adjust" $ run unary0 updateMinAdjustT + it "updateMin/delete" $ run unary0 updateMinDeleteT + it "updateMinWithKey/adjust" $ run unary0 updateMinWithKeyAdjustT + it "updateMinWithKey/delete" $ run unary0 updateMinWithKeyDeleteT + it "minView" $ run unary0 minViewT + + describe "Max" $ do + it "lookupMax" $ run unary0 lookupMaxT + it "lookupMaxWithKey" $ run unary0 lookupMaxWithKeyT + it "adjustMax" $ run unary0 adjustMaxT + it "adjustMaxWithKey" $ run unary0 adjustMaxWithKeyT + it "adjustMax'" $ run unary0 adjustMaxT' + it "adjustMaxWithKey'" $ run unary0 adjustMaxWithKeyT' + it "deleteMax" $ run unary0 deleteMaxT + it "updateMax/adjust" $ run unary0 updateMaxAdjustT + it "updateMax/delete" $ run unary0 updateMaxDeleteT + it "updateMaxWithKey/adjust" $ run unary0 updateMaxWithKeyAdjustT + it "updateMaxWithKey/delete" $ run unary0 updateMaxWithKeyDeleteT + it "maxView" $ run unary0 maxViewT + + describe "Partition" $ do + it "filter" $ run unary0 filterT + it "filterWithKey" $ run unary0 filterWithKeyT + it "mapMaybe" $ run unary0 mapMaybeT + it "mapMaybeWithKey" $ run unary0 mapMaybeWithKeyT + it "partition" $ run unary0 partitionT + it "partitionWithKey" $ run unary0 partitionWithKeyT + it "mapEither" $ run unary0 mapEitherT + it "mapEitherWithKey" $ run unary0 mapEitherWithKeyT + + describe "Full-tree" $ do + it "(==)" $ run (equal <> binaryL) eqT + it "map" $ run unary0 mapT + it "map'" $ run unary0 mapT' + it "mapWithKey" $ run unary0 mapWithKeyT + it "mapWithKey'" $ run unary0 mapWithKeyT' + it "size" $ run unary0 sizeT + it "foldl" $ run unary0 foldlT + it "foldl'" $ run unary0 foldlT' + it "foldlWithKey" $ run unary0 foldlWithKeyT + it "foldlWithKey'" $ run unary0 foldlWithKeyT' + it "foldr" $ run unary0 foldrT + it "foldr'" $ run unary0 foldrT' + it "foldrWithKey" $ run unary0 foldrWithKeyT + it "foldrWithKey'" $ run unary0 foldrWithKeyT' + it "foldMap" $ run unary0 foldMapT + it "foldMapWithKey" $ run unary0 foldMapWithKeyT + it "traverse" $ run unary0 traverseT + it "traverseWithKey" $ run unary0 traverseWithKeyT + + describe "Merge" $ do + it "union" $ run binary unionT + it "unionL" $ run binaryL unionLT + it "unionWith'" $ run binaryL unionWithT' + it "unionWithKey'" $ run binaryL unionWithKeyT' + it "difference" $ run binaryL differenceT + it "differenceWith" $ run binaryL differenceWithT + it "differenceWithKey" $ run binaryL differenceWithKeyT + it "disjoint/yes" $ run binary disjointT + it "disjoint/no" $ run binaryL disjointT + it "intersection" $ run binary intersectionT + it "intersectionL" $ run binaryL intersectionLT + it "intersectionWith'" $ run binaryL intersectionWithT' + it "intersectionWithKey'" $ run binaryL intersectionWithKeyT' + it "compare/subset" $ run subset compareT + it "compare/superset" $ run superset compareT + it "compare/equal" $ run equal compareT + it "compare/incomparable" $ run binary compareT + it "merge/union" $ run binaryL mergeUnionT + it "merge/difference" $ run binaryL mergeDifferenceT + it "merge/intersection" $ run binaryL mergeIntersectionT diff --git a/test/properties/Test/RadixNTree/Word8/Key.hs b/test/properties/Test/RadixNTree/Word8/Key.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/RadixNTree/Word8/Key.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE BangPatterns + , OverloadedLists + , OverloadedStrings #-} + +module Test.RadixNTree.Word8.Key + ( test + ) where + +import Data.RadixTree.Word8.Key as Radix +import Data.RadixTree.Word8.Key.Unsafe as Radix +import Data.Radix1Tree.Word8.Key as Radix1 +import Data.Radix1Tree.Word8.Key.Unsafe as Radix1 + +import qualified Data.ByteString.Lazy.Internal as LazyBS (ByteString (..)) +import Data.String +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Primitive.ByteArray as Prim +import qualified Data.Text.Array as Array +import qualified Data.Text.Internal as Strict (Text (..)) +import qualified Data.Text.Internal.Lazy as LazyText (Text (..)) +import Data.Word +import Test.Hspec + + + +buildRef :: Build +buildRef = Build (Snoc (Snoc (Snoc Lin [0xC2]) [0xA3, 0x24, 0xE2]) [0x82, 0xAC]) + +buildRef1 :: Build1 +buildRef1 = Build1 $ ((\(Build x) -> x) buildRef) :/ [0xC2, 0xA4] + + + +rawRef, rawRef1, utf8Ref, utf8Ref1 :: IsString a => a +rawRef = "\xC2\xA3$\xE2\x82\xAC" +rawRef1 = "\xC2\xA3$\xE2\x82\xAC\xC2\xA4" +utf8Ref = "£$€" +utf8Ref1 = "£$€¤" + + + +feedRef :: [Word8] +feedRef = [0xC2, 0xA3, 0x24, 0xE2, 0x82, 0xAC] + +feedRef1 :: NonEmpty Word8 +feedRef1 = 0xC2 :| [0xA3, 0x24, 0xE2, 0x82, 0xAC, 0xC2, 0xA4] + +destroy :: Feed -> [Word8] +destroy (Feed feed) = + feed $ \step -> + + let go s = + case step s of + More w s' -> w : go s' + Done -> [] + + in go + +destroy1 :: Feed1 -> NonEmpty Word8 +destroy1 (Feed1 w feed) = w :| destroy (Feed feed) + + + +test :: Spec +test = do + describe "build" $ do + it "bytes" $ + Radix.buildBytes buildRef `shouldBe` feedRef + + it "bytes/1" $ + Radix1.buildBytes buildRef1 `shouldBe` feedRef1 + + it "ByteString" $ + Radix.buildByteString buildRef `shouldBe` rawRef + + it "ByteString/1" $ + Radix1.buildByteString buildRef1 `shouldBe` rawRef1 + + it "ShortByteString" $ + Radix.buildShortByteString buildRef `shouldBe` rawRef + + it "ShortByteString/1" $ + Radix1.buildShortByteString buildRef1 `shouldBe` rawRef1 + + it "Text" $ + Radix.unsafeBuildText buildRef `shouldBe` utf8Ref + + it "Text/1" $ + Radix1.unsafeBuildText buildRef1 `shouldBe` utf8Ref1 + + describe "feed" $ do + it "bytes" $ + destroy (Radix.feedBytes feedRef) `shouldBe` feedRef + + it "bytes/1" $ + destroy1 (Radix1.feedBytes feedRef1) `shouldBe` feedRef1 + + it "ByteString" $ + destroy (Radix.feedByteString rawRef) `shouldBe` feedRef + + it "ByteString/1" $ + destroy1 (Radix1.unsafeFeedByteString rawRef1) `shouldBe` feedRef1 + + it "ShortByteString" $ + destroy (Radix.feedShortByteString rawRef) `shouldBe` feedRef + + it "ShortByteString/1" $ + destroy1 (Radix1.unsafeFeedShortByteString rawRef1) `shouldBe` feedRef1 + + it "Text" $ + destroy (Radix.feedText utf8Ref) `shouldBe` feedRef + + it "Text/1" $ + destroy1 (Radix1.unsafeFeedText utf8Ref1) `shouldBe` feedRef1 + + it "lazy ByteString" $ + let ref = LazyBS.Chunk [0xC2] . LazyBS.Chunk [0xA3, 0x24, 0xE2] + $ LazyBS.Chunk [0x82, 0xAC] LazyBS.Empty + + in destroy (Radix.feedLazyByteString ref) `shouldBe` feedRef + + it "lazy ByteString/1" $ + let rest = LazyBS.Chunk [0xA3, 0x24, 0xE2] + . LazyBS.Chunk [0x82, 0xAC] + $ LazyBS.Chunk [0xC2, 0xA4] LazyBS.Empty + + in destroy1 (Radix1.unsafeFeedLazyByteString "\xC2" rest) `shouldBe` feedRef1 + + it "lazy Text" $ + let !(Prim.ByteArray c1) = [0xC2] + !(Prim.ByteArray c2) = [0xA3, 0x24, 0xE2] + !(Prim.ByteArray c3) = [0x82, 0xAC] + + ref = LazyText.Chunk (Strict.Text (Array.ByteArray c1) 0 1) + . LazyText.Chunk (Strict.Text (Array.ByteArray c2) 0 3) + . LazyText.Chunk (Strict.Text (Array.ByteArray c3) 0 2) + $ LazyText.Empty + + in destroy (Radix.feedLazyText ref) `shouldBe` feedRef + + it "lazy Text/1" $ + let !(Prim.ByteArray c1) = [0xC2] + !(Prim.ByteArray c2) = [0xA3, 0x24, 0xE2] + !(Prim.ByteArray c3) = [0x82, 0xAC] + !(Prim.ByteArray c4) = [0xC2, 0xA4] + + first = Strict.Text (Array.ByteArray c1) 0 1 + + ref = LazyText.Chunk (Strict.Text (Array.ByteArray c2) 0 3) + . LazyText.Chunk (Strict.Text (Array.ByteArray c3) 0 2) + . LazyText.Chunk (Strict.Text (Array.ByteArray c4) 0 2) + $ LazyText.Empty + + in destroy1 (Radix1.unsafeFeedLazyText first ref) `shouldBe` feedRef1 diff --git a/test/properties/Test/RadixNTree/Word8/Sample.hs b/test/properties/Test/RadixNTree/Word8/Sample.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/RadixNTree/Word8/Sample.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.RadixNTree.Word8.Sample + ( Sample + , zero + , one + , tip + , bin + , tiny + , small + , medium +--, large + + , mkUnary0 + , mkUnary1 + , mkUnary2 + + , mkBinary + , mkBinaryL + + , mkEqual + , mkSuperset + , mkSubset + ) where + +import No.Tree (NoTree) +import qualified No.Tree as No +import Test.Kit +import Test.Random + +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Word +import System.Random + + + +data Trees = Trees (NonEmpty Tree) + | End + deriving Show + +data Tree = Tree + (NonEmpty Word8) + Bool -- ^ Whether this point is a separate key in the tree + Trees + deriving Show + + + +genTrees + :: RandomGen g + => Int -- ^ Maximum branches on each level + -> Int -- ^ Maximum number of segments + -> Int -- ^ Maximum segment length + -> Int -- ^ Maximum total length + -> g + -> (Trees, g) +genTrees nB nL nS nT = broad nL nT + where + broad count len g0 + | len <= 0 || count <= 0 = (End, g0) + | otherwise = + let ~(n, g1) = uniformR (1, nB) g0 + + ~(as, g2) = list1 (deep count len) n g1 + + in (Trees $ dedup as, g2) + + dedup = NonEmpty.nubBy (\(Tree (x :| _) _ _) (Tree (y :| _) _ _) -> x == y) + + deep count len g0 = + let ~(n, g1) = uniformR (1, max 1 (min len nS)) g0 + + ~(xs, g2) = list1 uniform n g1 + + ~(t, g3) = broad (count - 1) (len - n) g2 + + ~(bias, g4) = case t of + End -> (nL, g3) + _ -> uniformR (1, nL) g3 + + in (Tree xs (bias == 1) t, g4) + + + +timber :: Trees -> [([Word8], Int)] +timber = fst . broad id ([], 1) + where + broad pre ~(acc, n) End = ((pre [], n) : acc, n + 1) + broad pre z (Trees ts) = foldr (flip $ deep pre) z ts + + deep pre z@(acc, n) (Tree xs real t) = + let z' = if real + then ((pre $ NonEmpty.toList xs, n) : acc, n + 1) + else z + + in broad (pre . (NonEmpty.toList xs <>)) z' t + + + +data Sample = Sample + [(No.Openness, [Word8], Int)] -- ^ Keys in the dictionary + [(No.Openness, [Word8], Int)] -- ^ Keys not in the dictionary + deriving Show + +halve :: [a] -> ([a], [a]) +halve (a:b:cs) = let ~(xs, ys) = halve cs + in (a:xs, b:ys) +halve a = (a, []) + +sample :: RandomGen g => Trees -> g -> Sample +sample t g0 = + let ~(xs, g1) = shuffle (timber t) g0 + + ~(os, g2) = list (\g' -> let ~(b, g'') = uniform g' + in ( if b then No.Open else No.Closed + , g'' + ) + ) + (length xs) g1 + + xs' = zipWith (\a (b, c) -> (a, b, c)) os xs + + ~(ys, zs) = halve xs' + + ~(z, _) = uniform g2 + + as | z = case ys of + [] -> [] + (b, _, i) : rest -> (b, [], i) : rest + | otherwise = ys + + bs = case zs of + [] -> [] + (b, _, i) : rest -> (b, [], i) : rest + + in Sample as bs + + + +zero, one, tip, bin :: Sample +zero = Sample [] + [ (No.Open, [], 1), (No.Closed, [1, 2, 3], 2), (No.Open, [3, 2, 1], 3) ] + +one = Sample [(No.Open, [1, 2, 3], 0)] + [ (No.Closed, [1, 2, 3], 1), (No.Open, [1, 2, 2], 2), (No.Closed, [1, 2, 4], 3) + , (No.Open, [1, 2], 4), (No.Closed, [1, 2, 3, 4], 5), (No.Open, [2, 3, 4], 6) + , (No.Closed, [], 7), (No.Open, [2], 8) + ] + +tip = Sample [(No.Open, [], 0)] + [ (No.Closed, [1, 2, 3], 1), (No.Closed, [], 2) ] + +bin = Sample [(No.Open, [1, 2, 2, 3], 0), (No.Closed, [1, 2, 4, 5], 1)] + [ (No.Closed, [1, 2, 3, 4], 2), (No.Open, [1, 2, 2, 3], 3) + , (No.Closed, [1, 2, 4, 5], 4), (No.Closed, [], 5) + ] + + + +tiny, small, medium :: Sample +tiny = uncurry sample $ genTrees 4 2 4 16 (mkStdGen 2) +small = uncurry sample $ genTrees 4 4 4 16 (mkStdGen 4) +medium = uncurry sample $ genTrees 8 4 4 16 (mkStdGen 16) + + + +type FromList pat = forall x. [([Word8], x)] -> pat x + +mkUnary0 :: FromList pat -> Sample -> [Case () (pat Int) (NoTree [Word8] Int)] +mkUnary0 patFromList (Sample xs _) = + let as = fmap (\(_, k, i) -> (k, i)) xs + + in [Case () (patFromList as) (No.fromList as)] + +mkUnary1 + :: FromList pat + -> Sample -> [Case (No.Openness, [Word8], Int) (pat Int) (NoTree [Word8] Int)] +mkUnary1 patFromList (Sample xs ys) = + let as = fmap (\(_, k, i) -> (k, i)) xs + + pat = patFromList as + no = No.fromList as + + in foldr (\x -> (:) (Case x pat no)) [] $ xs <> ys + +mkUnary2 + :: FromList pat + -> Sample + -> [Case (No.Openness, [Word8], No.Openness, [Word8], Int) (pat Int) (NoTree [Word8] Int)] +mkUnary2 patFromList (Sample xs ys) = + let xs' = fmap (\(_, k, i) -> (k, i)) xs + + pat = patFromList xs' + no = No.fromList xs' + + ~(as, bs) = halve xs + ~(cs, ds) = halve ys + + ones = fmap (\(o, a, i) -> (o, a, o, a, i)) $ as <> cs + + twos = zipWith (\(o, a, i) (p, b, _) -> (o, a, p, b, i)) bs ds + + in foldr (\x -> (:) (Case x pat no)) [] $ ones <> twos + + + +mkBinary + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree [Word8] Int) (pat Int) (NoTree [Word8] Int)] +mkBinary patFromList (Sample xs ys) = + let as = fmap (\(_, k, i) -> (k, i)) xs + bs = fmap (\(_, k, i) -> (k, i)) ys + + in [Case (patFromList bs, No.fromList bs) (patFromList as) (No.fromList as)] + +mkBinaryL + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree [Word8] Int) (pat Int) (NoTree [Word8] Int)] +mkBinaryL patFromList (Sample xs ys) = + let xs' = fmap (\(_, k, i) -> (k, i)) xs + ys' = fmap (\(_, k, i) -> (k, i)) ys + + ~(as, _) = halve xs' + ~(bs, _) = halve ys' + + ls = fmap (\(k, a) -> (k, negate a)) bs <> xs' + rs = fmap (\(k, a) -> (k, negate a)) as <> ys' + + in [Case (patFromList rs, No.fromList rs) (patFromList ls) (No.fromList ls)] + +mkEqual + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree [Word8] Int) (pat Int) (NoTree [Word8] Int)] +mkEqual patFromList (Sample xs _) = + let as = fmap (\(_, k, i) -> (k, i)) xs + + pat = patFromList as + no = No.fromList as + + in [Case (pat, no) pat no] + +mkSuperset + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree [Word8] Int) (pat Int) (NoTree [Word8] Int)] +mkSuperset patFromList (Sample xs ys) = + let as = fmap (\(_, k, i) -> (k, i)) xs + bs = fmap (\(_, k, i) -> (k, i)) ys + + zs = as <> bs + + in [Case (patFromList zs, No.fromList zs) (patFromList as) (No.fromList as)] + +mkSubset + :: FromList pat + -> Sample + -> [Case (pat Int, NoTree [Word8] Int) (pat Int) (NoTree [Word8] Int)] +mkSubset patFromList (Sample xs ys) = + let as = fmap (\(_, k, i) -> (k, i)) xs + bs = fmap (\(_, k, i) -> (k, i)) ys + + zs = as <> bs + + in [Case (patFromList as, No.fromList as) (patFromList zs) (No.fromList zs)] diff --git a/test/properties/Test/RadixTree/Word8/Lazy.hs b/test/properties/Test/RadixTree/Word8/Lazy.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/RadixTree/Word8/Lazy.hs @@ -0,0 +1,820 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.RadixTree.Word8.Lazy + ( test + ) where + +import qualified Data.Radix1Tree.Word8.Lazy as Radix1 +import Data.RadixTree.Word8.Lazy (RadixTree) +import qualified Data.RadixTree.Word8.Lazy as Radix +import Data.RadixTree.Word8.Lazy.Debug +import qualified Data.RadixTree.Word8.Lazy.Unsafe as Radix +import No.Tree (NoTree) +import qualified No.Tree as No +import Test.Kit +import Test.RadixNTree.Word8.Sample + +import Data.Functor.Identity +import qualified Data.List as List +import Data.Word +import Test.Hspec + + + +radixFromList :: [([Word8], a)] -> RadixTree a +radixFromList = foldr (\(k, a) p -> Radix.insert (Radix.feedBytes k) a p) Radix.empty + +radixToList :: RadixTree a -> [([Word8], a)] +radixToList = Radix.foldrWithKey (\k a -> (:) (Radix.buildBytes k, a)) [] + + + +unary0 :: [Case () (RadixTree Int) (NoTree [Word8] Int)] +unary0 = foldMap (mkUnary0 radixFromList) [zero, one, tip, bin, tiny, small, medium] + +unary1F :: [Case (No.Openness, [Word8], Int) (RadixTree Int) (NoTree [Word8] Int)] +unary1F = foldMap (mkUnary1 radixFromList) [zero, one, tip, bin, tiny, small, medium] + +unary1R :: [Case (No.Openness, [Word8]) (RadixTree Int) (NoTree [Word8] Int)] +unary1R = augment (\(o, k, _) -> (o, k)) unary1F + +unary1 :: [Case ([Word8], Int) (RadixTree Int) (NoTree [Word8] Int)] +unary1 = augment (\(_, k, i) -> (k, i)) unary1F + +unary1_ :: [Case [Word8] (RadixTree Int) (NoTree [Word8] Int)] +unary1_ = augment (\(_, k, _) -> k) unary1F + + + +binary :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +binary = foldMap (mkBinary radixFromList) [zero, one, tip, bin, tiny, small, medium] + +binaryL :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +binaryL = foldMap (mkBinaryL radixFromList) [zero, one, tip, bin, tiny, small, medium] + +equal :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +equal = foldMap (mkEqual radixFromList) [zero, one, tip, bin, tiny, small, medium] + +subset :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +subset = foldMap (mkSubset radixFromList) [zero, one, tip, bin, tiny, small, medium] + +superset :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +superset = foldMap (mkSuperset radixFromList) [zero, one, tip, bin, tiny, small, medium] + + + +type IdT s a b = Test s (RadixTree a) (NoTree [Word8] a) b b + +type TreeT s a = Test s (RadixTree a) (NoTree [Word8] a) (RadixTree a) (NoTree [Word8] a) + +treeEq :: Eq a => RadixTree a -> NoTree [Word8] a -> Bool +treeEq pat no = + case validate pat of + Valid -> radixToList pat == No.toList no + _ -> False + +type SplitT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (RadixTree a, RadixTree a) (NoTree [Word8] a, NoTree [Word8] a) + +splitEq + :: Eq a => (RadixTree a, RadixTree a) -> (NoTree [Word8] a, NoTree [Word8] a) -> Bool +splitEq (a, b) (x, y) = treeEq a x && treeEq b y + +type SplitLookupT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (RadixTree a, Maybe a, RadixTree a) (NoTree [Word8] a, Maybe a, NoTree [Word8] a) + +splitLookupEq + :: Eq a + => (RadixTree a, Maybe a, RadixTree a) + -> (NoTree [Word8] a, Maybe a, NoTree [Word8] a) -> Bool +splitLookupEq (a, b, c) (x, y, z) = treeEq a x && b == y && treeEq c z + +type LookupT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (Maybe (Radix.Lookup a)) (Maybe ([Word8], a)) + +lookupEq :: Eq a => Maybe (Radix.Lookup a) -> Maybe ([Word8], a) -> Bool +lookupEq (Just (Radix.Lookup k a)) (Just (l, b)) = Radix.buildBytes k == l && a == b +lookupEq Nothing Nothing = True +lookupEq _ _ = False + +type MinViewT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (Maybe (Radix.ViewL a)) (Maybe ([Word8], a, NoTree [Word8] a)) + +minViewEq :: Eq a => Maybe (Radix.ViewL a) -> Maybe ([Word8], a, NoTree [Word8] a) -> Bool +minViewEq (Just (Radix.ViewL k a t)) (Just (l, b, no)) = + Radix.buildBytes k == l && a == b && treeEq t no + +minViewEq Nothing Nothing = True +minViewEq _ _ = False + +type MaxViewT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (Maybe (Radix.ViewR a)) (Maybe (NoTree [Word8] a, [Word8], a)) + +maxViewEq :: Eq a => Maybe (Radix.ViewR a) -> Maybe (NoTree [Word8] a, [Word8], a) -> Bool +maxViewEq (Just (Radix.ViewR t k a)) (Just (no, l, b)) = + Radix.buildBytes k == l && a == b && treeEq t no + +maxViewEq Nothing Nothing = True +maxViewEq _ _ = False + + + +lookupT :: Eq a => IdT [Word8] a (Maybe a) +lookupT = Test (==) (Radix.lookup . Radix.feedBytes) No.lookup + +findT :: Eq a => IdT ([Word8], a) a a +findT = Test (==) (\(k, i) -> Radix.find i $ Radix.feedBytes k) (\(k, i) -> No.find i k) + +memberT :: Eq a => IdT [Word8] a Bool +memberT = Test (==) (Radix.member . Radix.feedBytes) No.member + +subtreeT :: Eq a => TreeT [Word8] a +subtreeT = Test treeEq (Radix.subtree . Radix.feedBytes) No.subtree + +moveSingleT :: Eq a => IdT [Word8] a (Maybe a) +moveSingleT = + Test (==) (\k -> Radix.stop . Radix.move (Radix.feedBytes k) . Radix.cursor) + No.lookup + +moveThirdsT :: Eq a => IdT [Word8] a (Maybe a) +moveThirdsT = + let thirds xs = let len = length xs + ~(as, ys) = List.splitAt (len `quot` 3) xs + ~(bs, cs) = List.splitAt (len `quot` 3) ys + + in Radix.move (Radix.feedBytes cs) + . Radix.move (Radix.feedBytes bs) + . Radix.move (Radix.feedBytes as) + + in Test (==) (\k -> Radix.stop . thirds k . Radix.cursor) No.lookup + + + +prefixT :: Eq a => TreeT [Word8] a +prefixT = Test treeEq (Radix.prefix . Radix.feedBytes) No.prefix + +insertT :: Eq a => TreeT ([Word8], a) a +insertT = Test treeEq (\(k, i) -> Radix.insert (Radix.feedBytes k) i) (uncurry No.insert) + +insertWithT :: (Eq a, Integral a) => TreeT ([Word8], a) a +insertWithT = insertWithT_ Radix.insertWith + +insertWithT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Radix.Feed -> x -> RadixTree x -> RadixTree x) -> TreeT ([Word8], a) a +insertWithT_ g = + let f x = (+ fromIntegral x) + in Test treeEq (\(k, a) -> g (f a) (Radix.feedBytes k) a) + (\(k, a) -> No.insertWith (f a) k a) + +adjustT :: (Eq a, Integral a) => TreeT ([Word8], a) a +adjustT = adjustT_ Radix.adjust + +adjustT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Radix.Feed -> RadixTree x -> RadixTree x) -> TreeT ([Word8], a) a +adjustT_ g = + let f a = (+ fromIntegral a) + in Test treeEq (\(k, a) -> g (f a) (Radix.feedBytes k)) + (\(k, a) -> No.adjust (f a) k) + +deleteT :: Eq a => TreeT [Word8] a +deleteT = Test treeEq (Radix.delete . Radix.feedBytes) No.delete + +pruneT :: Eq a => TreeT (No.Openness, [Word8]) a +pruneT = Test treeEq (\(o, k) -> Radix.prune o $ Radix.feedBytes k) (uncurry No.prune) + +updateAdjustT, updateDeleteT :: (Eq a, Integral a) => TreeT ([Word8], a) a +updateAdjustT = updateT_ (\a -> Just . (+ a)) +updateDeleteT = updateT_ (\_ _ -> Nothing) + +updateT_ :: Eq a => (a -> a -> Maybe a) -> TreeT ([Word8], a) a +updateT_ f = Test treeEq (\(k, a) -> Radix.update (f a) (Radix.feedBytes k)) + (\(k, a) -> No.update (f a) k) + +alterInsertT + , alterInsertWithT + , alterAdjustT + , alterDeleteT + :: (Eq a, Integral a) => TreeT ([Word8], a) a +alterInsertT = alterT_ (\a _ -> Just a) +alterInsertWithT = alterT_ (\a -> Just . maybe a (+ a)) +alterAdjustT = alterT_ (\a -> fmap (+ a)) +alterDeleteT = alterT_ (\_ _ -> Nothing) + +alterT_ :: Eq a => (a -> Maybe a -> Maybe a) -> TreeT ([Word8], a) a +alterT_ f = Test treeEq (\(k, a) -> Radix.alter (f a) (Radix.feedBytes k)) + (\(k, a) -> No.alter (f a) k) + +shapeInsertT :: (Eq a, Integral a) => TreeT [Word8] a +shapeInsertT = + Test treeEq + (Radix.shape (Radix.insert (Radix.feedBytes [1, 2, 3]) 10000) . Radix.feedBytes) + (No.shape (No.insert [1, 2, 3] 10000)) + +shapeAdjustT :: (Eq a, Integral a) => TreeT [Word8] a +shapeAdjustT = Test treeEq (Radix.shape (Radix.map negate) . Radix.feedBytes) + (No.shape (No.map negate)) + +shapeFilterT :: (Eq a, Integral a) => TreeT [Word8] a +shapeFilterT = Test treeEq (Radix.shape (Radix.filter odd) . Radix.feedBytes) + (No.shape (No.filter odd)) + +shapeDeleteT :: (Eq a, Integral a) => TreeT [Word8] a +shapeDeleteT = Test treeEq (Radix.shape (\_ -> Radix.empty) . Radix.feedBytes) + (No.shape (\_ -> No.empty)) + + + +splitLT :: Eq a => SplitT (No.Openness, [Word8]) a +splitLT = Test splitEq (\(o, k) -> Radix.splitL o $ Radix.feedBytes k) (uncurry No.splitL) + +splitLookupT :: Eq a => SplitLookupT [Word8] a +splitLookupT = Test splitLookupEq (Radix.splitLookup . Radix.feedBytes) No.splitLookup + + + +lookupLT :: Eq a => LookupT (No.Openness, [Word8]) a +lookupLT = Test lookupEq (\(o, k) -> Radix.lookupL o $ Radix.feedBytes k) + (uncurry No.lookupL) + +adjustLT :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +adjustLT = adjustLT_ Radix.adjustL + +adjustLT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> No.Openness -> Radix.Feed -> RadixTree x -> RadixTree x) + -> TreeT (No.Openness, [Word8], a) a +adjustLT_ g = + let f a = (+ a) + in Test treeEq (\(o, k, a) -> g (f a) o $ Radix.feedBytes k) + (\(o, k, a) -> No.adjustL (f a) o k) + +adjustLWithKeyT :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +adjustLWithKeyT = adjustLWithKeyT_ Radix.adjustLWithKey + +adjustLWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Radix.Build -> x -> x) -> No.Openness -> Radix.Feed -> RadixTree x -> RadixTree x) + -> TreeT (No.Openness, [Word8], a) a +adjustLWithKeyT_ g = + let f a k = (+ sum (fmap fromIntegral k)) . (+ a) + in Test treeEq (\(o, k, a) -> g (f a . Radix.buildBytes) o $ Radix.feedBytes k) + (\(o, k, a) -> No.adjustLWithKey (f a) o k) + +updateLAdjustT + , updateLDeleteT + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +updateLAdjustT = updateLT_ (\a -> Just . (+ a)) +updateLDeleteT = updateLT_ (\_ _ -> Nothing) + +updateLT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (No.Openness, [Word8], a) a +updateLT_ f = + Test treeEq (\(o, k, a) -> Radix.updateL (f a) o $ Radix.feedBytes k) + (\(o, k, a) -> No.updateL (f a) o k) + +updateLWithKeyAdjustT + , updateLWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +updateLWithKeyAdjustT = updateLWithKeyT_ (\a k -> Just . (+ sum (fmap fromIntegral k)) . (+ a)) +updateLWithKeyDeleteT = updateLWithKeyT_ (\_ _ _ -> Nothing) + +updateLWithKeyT_ + :: (Eq a, Integral a) + => (a -> [Word8] -> a -> Maybe a) -> TreeT (No.Openness, [Word8], a) a +updateLWithKeyT_ f = + Test treeEq (\(o, k, a) -> Radix.updateLWithKey (f a . Radix.buildBytes) o $ Radix.feedBytes k) + (\(o, k, a) -> No.updateLWithKey (f a) o k) + +takeLT :: Eq a => TreeT (No.Openness, [Word8]) a +takeLT = Test treeEq (\(o, k) -> Radix.takeL o $ Radix.feedBytes k) + (uncurry No.takeL) + + + +lookupRT :: Eq a => LookupT (No.Openness, [Word8]) a +lookupRT = Test lookupEq (\(o, k) -> Radix.lookupR o $ Radix.feedBytes k) + (uncurry No.lookupR) + +adjustRT :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +adjustRT = adjustRT_ Radix.adjustR + +adjustRT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> No.Openness -> Radix.Feed -> RadixTree x -> RadixTree x) + -> TreeT (No.Openness, [Word8], a) a +adjustRT_ g = + let f a = (+ a) + in Test treeEq (\(o, k, a) -> g (f a) o $ Radix.feedBytes k) + (\(o, k, a) -> No.adjustR (f a) o k) + +adjustRWithKeyT :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +adjustRWithKeyT = adjustRWithKeyT_ Radix.adjustRWithKey + +adjustRWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Radix.Build -> x -> x) -> No.Openness -> Radix.Feed -> RadixTree x -> RadixTree x) + -> TreeT (No.Openness, [Word8], a) a +adjustRWithKeyT_ g = + let f a k = (+ sum (fmap fromIntegral k)) . (+ a) + in Test treeEq (\(o, k, a) -> g (f a . Radix.buildBytes) o $ Radix.feedBytes k) + (\(o, k, a) -> No.adjustRWithKey (f a) o k) + +updateRAdjustT + , updateRDeleteT + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +updateRAdjustT = updateRT_ (\a -> Just . (+ a)) +updateRDeleteT = updateRT_ (\_ _ -> Nothing) + +updateRT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (No.Openness, [Word8], a) a +updateRT_ f = + Test treeEq (\(o, k, a) -> Radix.updateR (f a) o $ Radix.feedBytes k) + (\(o, k, a) -> No.updateR (f a) o k) + +updateRWithKeyAdjustT + , updateRWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +updateRWithKeyAdjustT = updateRWithKeyT_ (\a k -> Just . (+ sum (fmap fromIntegral k)) . (+ a)) +updateRWithKeyDeleteT = updateRWithKeyT_ (\_ _ _ -> Nothing) + +updateRWithKeyT_ + :: (Eq a, Integral a) + => (a -> [Word8] -> a -> Maybe a) -> TreeT (No.Openness, [Word8], a) a +updateRWithKeyT_ f = + Test treeEq (\(o, k, a) -> Radix.updateRWithKey (f a . Radix.buildBytes) o $ Radix.feedBytes k) + (\(o, k, a) -> No.updateRWithKey (f a) o k) + +takeRT :: Eq a => TreeT (No.Openness, [Word8]) a +takeRT = Test treeEq (\(o, k) -> Radix.takeR o $ Radix.feedBytes k) + (uncurry No.takeR) + + + +lookupMinT :: Eq a => IdT () a (Maybe a) +lookupMinT = Test (==) (\_ -> Radix.lookupMin) (\_ -> No.lookupMin) + +lookupMinWithKeyT :: Eq a => LookupT () a +lookupMinWithKeyT = + Test lookupEq (\_ -> Radix.lookupMinWithKey) (\_ -> No.lookupMinWithKey) + +adjustMinT :: (Eq a, Integral a) => TreeT () a +adjustMinT = adjustMinT_ Radix.adjustMin + +adjustMinT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +adjustMinT_ f = Test treeEq (\_ -> f (+ 10000)) (\_ -> No.adjustMin (+ 10000)) + +adjustMinWithKeyT :: (Eq a, Integral a) => TreeT () a +adjustMinWithKeyT = adjustMinWithKeyT_ Radix.adjustMinWithKey + +adjustMinWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Radix.Build -> x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +adjustMinWithKeyT_ g = + let f k = (+ sum (fmap fromIntegral k)) + in Test treeEq (\_ -> g (f . Radix.buildBytes)) (\_ -> No.adjustMinWithKey f) + +deleteMinT :: (Eq a, Integral a) => TreeT () a +deleteMinT = Test treeEq (\_ -> Radix.deleteMin) (\_ -> No.deleteMin) + +updateMinAdjustT, updateMinDeleteT :: (Eq a, Integral a) => TreeT () a +updateMinAdjustT = updateMinT_ (Just . (+ 10000)) +updateMinDeleteT = updateMinT_ (\_ -> Nothing) + +updateMinT_ :: (Eq a, Integral a) => (a -> Maybe a) -> TreeT () a +updateMinT_ f = Test treeEq (\_ -> Radix.updateMin f) (\_ -> No.updateMin f) + +updateMinWithKeyAdjustT, updateMinWithKeyDeleteT :: (Eq a, Integral a) => TreeT () a +updateMinWithKeyAdjustT = updateMinWithKeyT_ (\k -> Just . (+ sum (fmap fromIntegral k))) +updateMinWithKeyDeleteT = updateMinWithKeyT_ (\_ _ -> Nothing) + +updateMinWithKeyT_ :: (Eq a, Integral a) => ([Word8] -> a -> Maybe a) -> TreeT () a +updateMinWithKeyT_ f = + Test treeEq (\_ -> Radix.updateMinWithKey (f . Radix.buildBytes)) + (\_ -> No.updateMinWithKey f) + +minViewT :: Eq a => MinViewT () a +minViewT = Test minViewEq (\_ -> Radix.minView) (\_ -> No.minView) + + + +lookupMaxT :: Eq a => IdT () a (Maybe a) +lookupMaxT = Test (==) (\_ -> Radix.lookupMax) (\_ -> No.lookupMax) + +lookupMaxWithKeyT :: Eq a => LookupT () a +lookupMaxWithKeyT = + Test lookupEq (\_ -> Radix.lookupMaxWithKey) (\_ -> No.lookupMaxWithKey) + +adjustMaxT :: (Eq a, Integral a) => TreeT () a +adjustMaxT = adjustMaxT_ Radix.adjustMax + +adjustMaxT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +adjustMaxT_ f = Test treeEq (\_ -> f (+ 10000)) (\_ -> No.adjustMax (+ 10000)) + +adjustMaxWithKeyT :: (Eq a, Integral a) => TreeT () a +adjustMaxWithKeyT = adjustMaxWithKeyT_ Radix.adjustMaxWithKey + +adjustMaxWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Radix.Build -> x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +adjustMaxWithKeyT_ g = + let f k = (+ sum (fmap fromIntegral k)) + in Test treeEq (\_ -> g (f . Radix.buildBytes)) (\_ -> No.adjustMaxWithKey f) + +deleteMaxT :: (Eq a, Integral a) => TreeT () a +deleteMaxT = Test treeEq (\_ -> Radix.deleteMax) (\_ -> No.deleteMax) + +updateMaxAdjustT, updateMaxDeleteT :: (Eq a, Integral a) => TreeT () a +updateMaxAdjustT = updateMaxT_ (Just . (+ 10000)) +updateMaxDeleteT = updateMaxT_ (\_ -> Nothing) + +updateMaxT_ :: (Eq a, Integral a) => (a -> Maybe a) -> TreeT () a +updateMaxT_ f = Test treeEq (\_ -> Radix.updateMax f) (\_ -> No.updateMax f) + +updateMaxWithKeyAdjustT, updateMaxWithKeyDeleteT :: (Eq a, Integral a) => TreeT () a +updateMaxWithKeyAdjustT = updateMaxWithKeyT_ (\k -> Just . (+ sum (fmap fromIntegral k))) +updateMaxWithKeyDeleteT = updateMaxWithKeyT_ (\_ _ -> Nothing) + +updateMaxWithKeyT_ :: (Eq a, Integral a) => ([Word8] -> a -> Maybe a) -> TreeT () a +updateMaxWithKeyT_ f = + Test treeEq (\_ -> Radix.updateMaxWithKey (f . Radix.buildBytes)) + (\_ -> No.updateMaxWithKey f) + +maxViewT :: Eq a => MaxViewT () a +maxViewT = Test maxViewEq (\_ -> Radix.maxView) (\_ -> No.maxView) + + + +filterT :: (Eq a, Integral a) => TreeT () a +filterT = Test treeEq (\_ -> Radix.filter odd) (\_ -> No.filter odd) + +filterWithKeyT :: (Eq a, Integral a) => TreeT () a +filterWithKeyT = + let f k a = odd $ sum (fmap fromIntegral k) + a + in Test treeEq (\_ -> Radix.filterWithKey (f . Radix.buildBytes)) + (\_ -> No.filterWithKey f) + +mapMaybeT :: (Eq a, Integral a) => TreeT () a +mapMaybeT = + let f a | odd a = Nothing + | otherwise = Just a + + in Test treeEq (\_ -> Radix.mapMaybe f) (\_ -> No.mapMaybe f) + +mapMaybeWithKeyT :: (Eq a, Integral a) => TreeT () a +mapMaybeWithKeyT = + let f k a | odd (sum (fmap fromIntegral k) + a) = Nothing + | otherwise = Just a + + in Test treeEq (\_ -> Radix.mapMaybeWithKey (f . Radix.buildBytes)) + (\_ -> No.mapMaybeWithKey f) + +partitionT :: (Eq a, Integral a) => SplitT () a +partitionT = Test splitEq (\_ -> Radix.partition odd) (\_ -> No.partition odd) + +partitionWithKeyT :: (Eq a, Integral a) => SplitT () a +partitionWithKeyT = + let f k a = odd $ sum (fmap fromIntegral k) + a + in Test splitEq (\_ -> Radix.partitionWithKey (f . Radix.buildBytes)) + (\_ -> No.partitionWithKey f) + +mapEitherT :: (Eq a, Integral a) => SplitT () a +mapEitherT = + let f a | odd a = Left a + | otherwise = Right a + + in Test splitEq (\_ -> Radix.mapEither f) (\_ -> No.mapEither f) + +mapEitherWithKeyT :: (Eq a, Integral a) => SplitT () a +mapEitherWithKeyT = + let f k a | odd (sum (fmap fromIntegral k) + a) = Left a + | otherwise = Right a + + in Test splitEq (\_ -> Radix.mapEitherWithKey (f . Radix.buildBytes)) + (\_ -> No.mapEitherWithKey f) + + + +mapT :: (Eq a, Num a) => TreeT () a +mapT = mapT_ Radix.map + +mapT_ :: (Eq a, Num a) => (forall x. (x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +mapT_ g = + let f = (+ 10000) + in Test treeEq (\_ -> g f) (\_ -> No.map f) + +mapWithKeyT :: (Eq a, Num a) => TreeT () a +mapWithKeyT = mapWithKeyT_ Radix.mapWithKey + +mapWithKeyT_ + :: (Eq a, Num a) + => (forall x. (Radix.Build -> x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +mapWithKeyT_ g = + let f k = (+ sum (fmap fromIntegral k)) . (+ 10000) + in Test treeEq (\_ -> g (f . Radix.buildBytes)) (\_ -> No.mapWithKey f) + + +foldlT, foldlT' :: (Eq a, Num a) => IdT () a [a] +foldlT = foldlT_ Radix.foldl +foldlT' = foldlT_ Radix.foldl' + +foldlT_ :: Eq a => (forall x. (x -> a -> x) -> x -> RadixTree a -> x) -> IdT () a [a] +foldlT_ g = + Test (==) (\_ -> g (flip (:)) []) (\_ -> No.foldl (flip (:)) []) + +foldlWithKeyT, foldlWithKeyT' :: Eq a => IdT () a [([Word8], a)] +foldlWithKeyT = foldlWithKeyT_ Radix.foldlWithKey +foldlWithKeyT' = foldlWithKeyT_ Radix.foldlWithKey' + +foldlWithKeyT_ + :: Eq a + => (forall x. (x -> Radix.Build -> a -> x) -> x -> RadixTree a -> x) + -> IdT () a [([Word8], a)] +foldlWithKeyT_ g = + Test (==) (\_ -> g (\z k a -> (Radix.buildBytes k, a) : z) []) + (\_ -> No.foldlWithKey (\z k a -> (k, a) : z) []) + + + +foldrT, foldrT' :: Eq a => IdT () a [a] +foldrT = foldrT_ Radix.foldr +foldrT' = foldrT_ Radix.foldr' + +foldrT_ :: Eq a => (forall x. (a -> x -> x) -> x -> RadixTree a -> x) -> IdT () a [a] +foldrT_ g = Test (==) (\_ -> g (:) []) (\_ -> No.foldr (:) []) + +foldrWithKeyT, foldrWithKeyT' :: (Eq a, Num a) => IdT () a [([Word8], a)] +foldrWithKeyT = foldrWithKeyT_ Radix.foldrWithKey +foldrWithKeyT' = foldrWithKeyT_ Radix.foldrWithKey' + +foldrWithKeyT_ + :: (Eq a, Num a) + => (forall y. (Radix.Build -> a -> y -> y) -> y -> RadixTree a -> y) + -> IdT () a [([Word8], a)] +foldrWithKeyT_ g = Test (==) (\_ -> g (\k a -> (:) (Radix.buildBytes k, a)) []) + (\_ -> No.foldrWithKey (\k a -> (:) (k, a)) []) + + + +foldMapT :: Eq a => IdT () a [a] +foldMapT = Test (==) (\_ -> Radix.foldMap (:[])) (\_ -> No.foldMap (:[])) + +foldMapWithKeyT :: Eq a => IdT () a [([Word8], a)] +foldMapWithKeyT = + Test (==) (\_ -> Radix.foldMapWithKey (\k a -> [(Radix.buildBytes k, a)])) + (\_ -> No.foldMapWithKey (\k a -> [(k, a)])) + + + +idTreeEq :: Eq a => Identity (RadixTree a) -> Identity (NoTree [Word8] a) -> Bool +idTreeEq (Identity a) (Identity b) = treeEq a b + +traverseT + :: (Eq a, Num a) + => Test s (RadixTree a) (NoTree [Word8] a) + (Identity (RadixTree a)) (Identity (NoTree [Word8] a)) +traverseT = + let f = Identity . (+ 10000) + in Test idTreeEq (\_ -> Radix.traverse f) (\_ -> No.traverse f) + +traverseWithKeyT + :: (Eq a, Num a) + => Test s (RadixTree a) (NoTree [Word8] a) + (Identity (RadixTree a)) (Identity (NoTree [Word8] a)) +traverseWithKeyT = + let f k a = Identity $ sum (fmap fromIntegral k) + 10000 + a + in Test idTreeEq (\_ -> Radix.traverseWithKey (f . Radix.buildBytes)) + (\_ -> No.traverseWithKey f) + + + +unionT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +unionT = Test treeEq (Radix.union . fst) (No.unionL . snd) + +unionLT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +unionLT = Test treeEq (Radix.unionL . fst) (No.unionL . snd) + +unionWithT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +unionWithT = Test treeEq (Radix.unionWith (\_ y -> y) . fst) + (No.unionWithKey (\_ _ y -> y) . snd) + +unionWithKeyT, mergeUnionT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +unionWithKeyT = unionWithKeyT_ Radix.unionWithKey +mergeUnionT = + unionWithKeyT_ $ \f -> + Radix.merge (\k a b -> Just $! f k a b) + (\_ -> Just) (\_ -> id) (\_ -> Just) (\_ -> id) + +unionWithKeyT_ + :: Eq a + => ((Radix.Build -> a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a) + -> TreeT (RadixTree a, NoTree [Word8] a) a +unionWithKeyT_ g = + let f k a b | odd $ sum (fmap (fromIntegral :: Word8 -> Int) k) = a + | otherwise = b + + in Test treeEq (g (f . Radix.buildBytes) . fst) + (No.unionWithKey f . snd) + + + +differenceT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +differenceT = Test treeEq (Radix.difference . fst) (No.difference . snd) + +differenceWithT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +differenceWithT = Test treeEq (Radix.differenceWith (\_ -> Just) . fst) + (No.differenceWithKey (\_ _ -> Just) . snd) + +differenceWithKeyT + , mergeDifferenceT + :: (Eq a, Integral a) => TreeT (RadixTree a, NoTree [Word8] a) a +differenceWithKeyT = differenceWithKeyT_ Radix.differenceWithKey +mergeDifferenceT = + differenceWithKeyT_ $ \f -> + Radix.merge f (\_ -> Just) (\_ -> id) (\_ _ -> Nothing) (\_ _ -> Radix1.empty) + +differenceWithKeyT_ + :: (Eq a, Integral a) + => ((Radix.Build -> a -> a -> Maybe a) -> RadixTree a -> RadixTree a -> RadixTree a) + -> TreeT (RadixTree a, NoTree [Word8] a) a +differenceWithKeyT_ g = + let f k a b | odd $ sum (fmap (fromIntegral :: Word8 -> Int) k) = Just a + | otherwise = if even b + then Just b + else Nothing + in Test treeEq (g (f . Radix.buildBytes) . fst) + (No.differenceWithKey f . snd) + + + +disjointT :: Eq a => IdT (RadixTree a, NoTree [Word8] a) a Bool +disjointT = Test (==) (Radix.disjoint . fst) (\(_, a) -> No.null . No.intersectionL a) + +intersectionT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +intersectionT = Test treeEq (Radix.intersection . fst) (No.intersectionL . snd) + +intersectionLT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +intersectionLT = Test treeEq (Radix.intersectionL . fst) (No.intersectionL . snd) + +intersectionWithT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +intersectionWithT = Test treeEq (Radix.intersectionWith (\_ y -> y) . fst) + (No.intersectionWithKey (\_ _ y -> y) . snd) + +intersectionWithKeyT, mergeIntersectionT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +intersectionWithKeyT = intersectionWithKeyT_ Radix.intersectionWithKey +mergeIntersectionT = + intersectionWithKeyT_ $ \f -> + Radix.merge (\k a b -> Just $! f k a b) + (\_ _ -> Nothing) (\_ _ -> Radix1.empty) (\_ _ -> Nothing) (\_ _ -> Radix1.empty) + +intersectionWithKeyT_ + :: Eq a + => ((Radix.Build -> a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a) + -> TreeT (RadixTree a, NoTree [Word8] a) a +intersectionWithKeyT_ g = + let f k a b | odd $ sum (fmap (fromIntegral :: Word8 -> Int) k) = a + | otherwise = b + + in Test treeEq (g (f . Radix.buildBytes) . fst) + (No.intersectionWithKey f . snd) + + + +compareT :: Eq a => IdT (RadixTree a, NoTree [Word8] a) a Radix.PartialOrdering +compareT = Test (==) (Radix.compare (==) . fst) (No.compare . snd) + + + +test :: Spec +test = do + describe "Single-key" $ do + it "lookup" $ run unary1_ lookupT + it "find" $ run unary1 findT + it "member" $ run unary1_ memberT + it "subtree" $ run unary1_ subtreeT + it "move/single" $ run unary1_ moveSingleT + it "move/thirds" $ run unary1_ moveThirdsT + it "insert" $ run unary1 insertT + it "insertWith" $ run unary1 insertWithT + it "adjust" $ run unary1 adjustT + it "delete" $ run unary1_ deleteT + it "prune" $ run unary1R pruneT + it "update/adjust" $ run unary1 updateAdjustT + it "update/delete" $ run unary1 updateDeleteT + it "alter/insert" $ run unary1 alterInsertT + it "alter/insertWith" $ run unary1 alterInsertWithT + it "alter/adjust" $ run unary1 alterAdjustT + it "alter/delete" $ run unary1 alterDeleteT + it "shape/insert" $ run unary1_ shapeInsertT + it "shape/adjust" $ run unary1_ shapeAdjustT + it "shape/filter" $ run unary1_ shapeFilterT + it "shape/delete" $ run unary1_ shapeDeleteT + + describe "Split" $ do + it "splitL" $ run unary1R splitLT + it "splitLookup" $ run unary1_ splitLookupT + + describe "Left" $ do + it "lookupL" $ run unary1R lookupLT + it "adjustL" $ run unary1F adjustLT + it "adjustLWithKey" $ run unary1F adjustLWithKeyT + it "updateL/adjust" $ run unary1F updateLAdjustT + it "updateL/delete" $ run unary1F updateLDeleteT + it "updateLWithKey/adjust" $ run unary1F updateLWithKeyAdjustT + it "updateLWithKey/delete" $ run unary1F updateLWithKeyDeleteT + it "takeL" $ run unary1R takeLT + + describe "Right" $ do + it "lookupR" $ run unary1R lookupRT + it "adjustR" $ run unary1F adjustRT + it "adjustRWithKey" $ run unary1F adjustRWithKeyT + it "updateR/adjust" $ run unary1F updateRAdjustT + it "updateR/delete" $ run unary1F updateRDeleteT + it "updateRWithKey/adjust" $ run unary1F updateRWithKeyAdjustT + it "updateRWithKey/delete" $ run unary1F updateRWithKeyDeleteT + it "takeR" $ run unary1R takeRT + + describe "Min" $ do + it "lookupMin" $ run unary0 lookupMinT + it "lookupMinWithKey" $ run unary0 lookupMinWithKeyT + it "adjustMin" $ run unary0 adjustMinT + it "adjustMinWithKey" $ run unary0 adjustMinWithKeyT + it "deleteMin" $ run unary0 deleteMinT + it "updateMin/adjust" $ run unary0 updateMinAdjustT + it "updateMin/delete" $ run unary0 updateMinDeleteT + it "updateMinWithKey/adjust" $ run unary0 updateMinWithKeyAdjustT + it "updateMinWithKey/delete" $ run unary0 updateMinWithKeyDeleteT + it "minView" $ run unary0 minViewT + + describe "Max" $ do + it "lookupMax" $ run unary0 lookupMaxT + it "lookupMaxWithKey" $ run unary0 lookupMaxWithKeyT + it "adjustMax" $ run unary0 adjustMaxT + it "adjustMaxWithKey" $ run unary0 adjustMaxWithKeyT + it "deleteMax" $ run unary0 deleteMaxT + it "updateMax/adjust" $ run unary0 updateMaxAdjustT + it "updateMax/delete" $ run unary0 updateMaxDeleteT + it "updateMaxWithKey/adjust" $ run unary0 updateMaxWithKeyAdjustT + it "updateMaxWithKey/delete" $ run unary0 updateMaxWithKeyDeleteT + it "maxView" $ run unary0 maxViewT + + describe "Partition" $ do + it "filter" $ run unary0 filterT + it "filterWithKey" $ run unary0 filterWithKeyT + it "mapMaybe" $ run unary0 mapMaybeT + it "mapMaybeWithKey" $ run unary0 mapMaybeWithKeyT + it "partition" $ run unary0 partitionT + it "partitionWithKey" $ run unary0 partitionWithKeyT + it "mapEither" $ run unary0 mapEitherT + it "mapEitherWithKey" $ run unary0 mapEitherWithKeyT + + describe "Full-tree" $ do + it "prefix" $ run unary1_ prefixT + it "map" $ run unary0 mapT + it "mapWithKey" $ run unary0 mapWithKeyT + it "foldl" $ run unary0 foldlT + it "foldl'" $ run unary0 foldlT' + it "foldlWithKey" $ run unary0 foldlWithKeyT + it "foldlWithKey'" $ run unary0 foldlWithKeyT' + it "foldr" $ run unary0 foldrT + it "foldr'" $ run unary0 foldrT' + it "foldrWithKey" $ run unary0 foldrWithKeyT + it "foldrWithKey'" $ run unary0 foldrWithKeyT' + it "foldMap" $ run unary0 foldMapT + it "foldMapWithKey" $ run unary0 foldMapWithKeyT + it "traverse" $ run unary0 traverseT + it "traverseWithKey" $ run unary0 traverseWithKeyT + + describe "Merge" $ do + it "union" $ run binary unionT + it "unionL" $ run binaryL unionLT + it "unionWith" $ run binaryL unionWithT + it "unionWithKey" $ run binaryL unionWithKeyT + it "difference" $ run binaryL differenceT + it "differenceWith" $ run binaryL differenceWithT + it "differenceWithKey" $ run binaryL differenceWithKeyT + it "disjoint/yes" $ run binary disjointT + it "disjoint/no" $ run binaryL disjointT + it "intersection" $ run binary intersectionT + it "intersectionL" $ run binaryL intersectionLT + it "intersectionWith" $ run binaryL intersectionWithT + it "intersectionWithKey" $ run binaryL intersectionWithKeyT + it "compare/subset" $ run subset compareT + it "compare/superset" $ run superset compareT + it "compare/equal" $ run equal compareT + it "compare/incomparable" $ run binary compareT + it "merge/union" $ run binaryL mergeUnionT + it "merge/difference" $ run binaryL mergeDifferenceT + it "merge/intersection" $ run binaryL mergeIntersectionT diff --git a/test/properties/Test/RadixTree/Word8/Strict.hs b/test/properties/Test/RadixTree/Word8/Strict.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/RadixTree/Word8/Strict.hs @@ -0,0 +1,848 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.RadixTree.Word8.Strict + ( test + ) where + +import qualified Data.Radix1Tree.Word8.Strict as Radix1 +import Data.RadixTree.Word8.Strict (RadixTree) +import qualified Data.RadixTree.Word8.Strict as Radix +import Data.RadixTree.Word8.Strict.Debug +import qualified Data.RadixTree.Word8.Strict.Unsafe as Radix +import No.Tree (NoTree) +import qualified No.Tree as No +import Test.Kit +import Test.RadixNTree.Word8.Sample + +import Data.Functor.Identity +import qualified Data.List as List +import Data.Word +import Test.Hspec + + + +radixFromList :: [([Word8], a)] -> RadixTree a +radixFromList = foldr (\(k, a) p -> Radix.insert (Radix.feedBytes k) a p) Radix.empty + +radixToList :: RadixTree a -> [([Word8], a)] +radixToList = Radix.foldrWithKey (\k a -> (:) (Radix.buildBytes k, a)) [] + + + +unary0 :: [Case () (RadixTree Int) (NoTree [Word8] Int)] +unary0 = foldMap (mkUnary0 radixFromList) [zero, one, tip, bin, tiny, small, medium] + +unary1F :: [Case (No.Openness, [Word8], Int) (RadixTree Int) (NoTree [Word8] Int)] +unary1F = foldMap (mkUnary1 radixFromList) [zero, one, tip, bin, tiny, small, medium] + +unary1R :: [Case (No.Openness, [Word8]) (RadixTree Int) (NoTree [Word8] Int)] +unary1R = augment (\(o, k, _) -> (o, k)) unary1F + +unary1 :: [Case ([Word8], Int) (RadixTree Int) (NoTree [Word8] Int)] +unary1 = augment (\(_, k, i) -> (k, i)) unary1F + +unary1_ :: [Case [Word8] (RadixTree Int) (NoTree [Word8] Int)] +unary1_ = augment (\(_, k, _) -> k) unary1F + + + +binary :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +binary = foldMap (mkBinary radixFromList) [zero, one, tip, bin, tiny, small, medium] + +binaryL :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +binaryL = foldMap (mkBinaryL radixFromList) [zero, one, tip, bin, tiny, small, medium] + +equal :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +equal = foldMap (mkEqual radixFromList) [zero, one, tip, bin, tiny, small, medium] + +subset :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +subset = foldMap (mkSubset radixFromList) [zero, one, tip, bin, tiny, small, medium] + +superset :: [Case (RadixTree Int, NoTree [Word8] Int) (RadixTree Int) (NoTree [Word8] Int)] +superset = foldMap (mkSuperset radixFromList) [zero, one, tip, bin, tiny, small, medium] + + + +type IdT s a b = Test s (RadixTree a) (NoTree [Word8] a) b b + +type TreeT s a = Test s (RadixTree a) (NoTree [Word8] a) (RadixTree a) (NoTree [Word8] a) + +treeEq :: Eq a => RadixTree a -> NoTree [Word8] a -> Bool +treeEq pat no = + case validate pat of + Valid -> radixToList pat == No.toList no + _ -> False + +type SplitT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (Radix.Split a a) (NoTree [Word8] a, NoTree [Word8] a) + +splitEq :: Eq a => Radix.Split a a -> (NoTree [Word8] a, NoTree [Word8] a) -> Bool +splitEq (Radix.Split a b) (x, y) = treeEq a x && treeEq b y + +type SplitLookupT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (Radix.SplitLookup a a a) (NoTree [Word8] a, Maybe a, NoTree [Word8] a) + +splitLookupEq + :: Eq a + => Radix.SplitLookup a a a -> (NoTree [Word8] a, Maybe a, NoTree [Word8] a) -> Bool +splitLookupEq (Radix.SplitLookup a b c) (x, y, z) = treeEq a x && b == y && treeEq c z + +type LookupT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (Maybe (Radix.Lookup a)) (Maybe ([Word8], a)) + +lookupEq :: Eq a => Maybe (Radix.Lookup a) -> Maybe ([Word8], a) -> Bool +lookupEq (Just (Radix.Lookup k a)) (Just (l, b)) = Radix.buildBytes k == l && a == b +lookupEq Nothing Nothing = True +lookupEq _ _ = False + +type MinViewT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (Maybe (Radix.ViewL a)) (Maybe ([Word8], a, NoTree [Word8] a)) + +minViewEq :: Eq a => Maybe (Radix.ViewL a) -> Maybe ([Word8], a, NoTree [Word8] a) -> Bool +minViewEq (Just (Radix.ViewL k a t)) (Just (l, b, no)) = + Radix.buildBytes k == l && a == b && treeEq t no + +minViewEq Nothing Nothing = True +minViewEq _ _ = False + +type MaxViewT s a = + Test s (RadixTree a) (NoTree [Word8] a) + (Maybe (Radix.ViewR a)) (Maybe (NoTree [Word8] a, [Word8], a)) + +maxViewEq :: Eq a => Maybe (Radix.ViewR a) -> Maybe (NoTree [Word8] a, [Word8], a) -> Bool +maxViewEq (Just (Radix.ViewR t k a)) (Just (no, l, b)) = + Radix.buildBytes k == l && a == b && treeEq t no + +maxViewEq Nothing Nothing = True +maxViewEq _ _ = False + + + +lookupT :: Eq a => IdT [Word8] a (Maybe a) +lookupT = Test (==) (Radix.lookup . Radix.feedBytes) No.lookup + +findT :: Eq a => IdT ([Word8], a) a a +findT = Test (==) (\(k, i) -> Radix.find i $ Radix.feedBytes k) (\(k, i) -> No.find i k) + +memberT :: Eq a => IdT [Word8] a Bool +memberT = Test (==) (Radix.member . Radix.feedBytes) No.member + +subtreeT :: Eq a => TreeT [Word8] a +subtreeT = Test treeEq (Radix.subtree . Radix.feedBytes) No.subtree + +moveSingleT :: Eq a => IdT [Word8] a (Maybe a) +moveSingleT = + Test (==) (\k -> Radix.stop . Radix.move (Radix.feedBytes k) . Radix.cursor) + No.lookup + +moveThirdsT :: Eq a => IdT [Word8] a (Maybe a) +moveThirdsT = + let thirds xs = let len = length xs + ~(as, ys) = List.splitAt (len `quot` 3) xs + ~(bs, cs) = List.splitAt (len `quot` 3) ys + + in Radix.move (Radix.feedBytes cs) + . Radix.move (Radix.feedBytes bs) + . Radix.move (Radix.feedBytes as) + + in Test (==) (\k -> Radix.stop . thirds k . Radix.cursor) No.lookup + + + +prefixT :: Eq a => TreeT [Word8] a +prefixT = Test treeEq (Radix.prefix . Radix.feedBytes) No.prefix + +insertT :: Eq a => TreeT ([Word8], a) a +insertT = Test treeEq (\(k, i) -> Radix.insert (Radix.feedBytes k) i) (uncurry No.insert) + +insertWithT, insertWithT' :: (Eq a, Integral a) => TreeT ([Word8], a) a +insertWithT = insertWithT_ Radix.insertWith +insertWithT' = insertWithT_ Radix.insertWith' + +insertWithT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Radix.Feed -> x -> RadixTree x -> RadixTree x) -> TreeT ([Word8], a) a +insertWithT_ g = + let f x = (+ fromIntegral x) + in Test treeEq (\(k, a) -> g (f a) (Radix.feedBytes k) a) + (\(k, a) -> No.insertWith (f a) k a) + +adjustT, adjustT' :: (Eq a, Integral a) => TreeT ([Word8], a) a +adjustT = adjustT_ Radix.adjust +adjustT' = adjustT_ Radix.adjust' + +adjustT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> Radix.Feed -> RadixTree x -> RadixTree x) -> TreeT ([Word8], a) a +adjustT_ g = + let f a = (+ fromIntegral a) + in Test treeEq (\(k, a) -> g (f a) (Radix.feedBytes k)) + (\(k, a) -> No.adjust (f a) k) + +deleteT :: Eq a => TreeT [Word8] a +deleteT = Test treeEq (Radix.delete . Radix.feedBytes) No.delete + +pruneT :: Eq a => TreeT (No.Openness, [Word8]) a +pruneT = Test treeEq (\(o, k) -> Radix.prune o $ Radix.feedBytes k) (uncurry No.prune) + +updateAdjustT, updateDeleteT :: (Eq a, Integral a) => TreeT ([Word8], a) a +updateAdjustT = updateT_ (\a -> Just . (+ a)) +updateDeleteT = updateT_ (\_ _ -> Nothing) + +updateT_ :: Eq a => (a -> a -> Maybe a) -> TreeT ([Word8], a) a +updateT_ f = Test treeEq (\(k, a) -> Radix.update (f a) (Radix.feedBytes k)) + (\(k, a) -> No.update (f a) k) + +alterInsertT + , alterInsertWithT + , alterAdjustT + , alterDeleteT + :: (Eq a, Integral a) => TreeT ([Word8], a) a +alterInsertT = alterT_ (\a _ -> Just a) +alterInsertWithT = alterT_ (\a -> Just . maybe a (+ a)) +alterAdjustT = alterT_ (\a -> fmap (+ a)) +alterDeleteT = alterT_ (\_ _ -> Nothing) + +alterT_ :: Eq a => (a -> Maybe a -> Maybe a) -> TreeT ([Word8], a) a +alterT_ f = Test treeEq (\(k, a) -> Radix.alter (f a) (Radix.feedBytes k)) + (\(k, a) -> No.alter (f a) k) + +shapeInsertT :: (Eq a, Integral a) => TreeT [Word8] a +shapeInsertT = + Test treeEq + (Radix.shape (Radix.insert (Radix.feedBytes [1, 2, 3]) 10000) . Radix.feedBytes) + (No.shape (No.insert [1, 2, 3] 10000)) + +shapeAdjustT :: (Eq a, Integral a) => TreeT [Word8] a +shapeAdjustT = Test treeEq (Radix.shape (Radix.map negate) . Radix.feedBytes) + (No.shape (No.map negate)) + +shapeFilterT :: (Eq a, Integral a) => TreeT [Word8] a +shapeFilterT = Test treeEq (Radix.shape (Radix.filter odd) . Radix.feedBytes) + (No.shape (No.filter odd)) + +shapeDeleteT :: (Eq a, Integral a) => TreeT [Word8] a +shapeDeleteT = Test treeEq (Radix.shape (\_ -> Radix.empty) . Radix.feedBytes) + (No.shape (\_ -> No.empty)) + + + +splitLT :: Eq a => SplitT (No.Openness, [Word8]) a +splitLT = Test splitEq (\(o, k) -> Radix.splitL o $ Radix.feedBytes k) (uncurry No.splitL) + +splitLookupT :: Eq a => SplitLookupT [Word8] a +splitLookupT = Test splitLookupEq (Radix.splitLookup . Radix.feedBytes) No.splitLookup + + + +lookupLT :: Eq a => LookupT (No.Openness, [Word8]) a +lookupLT = Test lookupEq (\(o, k) -> Radix.lookupL o $ Radix.feedBytes k) + (uncurry No.lookupL) + +adjustLT, adjustLT' :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +adjustLT = adjustLT_ Radix.adjustL +adjustLT' = adjustLT_ Radix.adjustL' + +adjustLT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> No.Openness -> Radix.Feed -> RadixTree x -> RadixTree x) + -> TreeT (No.Openness, [Word8], a) a +adjustLT_ g = + let f a = (+ a) + in Test treeEq (\(o, k, a) -> g (f a) o $ Radix.feedBytes k) + (\(o, k, a) -> No.adjustL (f a) o k) + +adjustLWithKeyT + , adjustLWithKeyT' + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +adjustLWithKeyT = adjustLWithKeyT_ Radix.adjustLWithKey +adjustLWithKeyT' = adjustLWithKeyT_ Radix.adjustLWithKey' + +adjustLWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Radix.Build -> x -> x) -> No.Openness -> Radix.Feed -> RadixTree x -> RadixTree x) + -> TreeT (No.Openness, [Word8], a) a +adjustLWithKeyT_ g = + let f a k = (+ sum (fmap fromIntegral k)) . (+ a) + in Test treeEq (\(o, k, a) -> g (f a . Radix.buildBytes) o $ Radix.feedBytes k) + (\(o, k, a) -> No.adjustLWithKey (f a) o k) + +updateLAdjustT + , updateLDeleteT + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +updateLAdjustT = updateLT_ (\a -> Just . (+ a)) +updateLDeleteT = updateLT_ (\_ _ -> Nothing) + +updateLT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (No.Openness, [Word8], a) a +updateLT_ f = + Test treeEq (\(o, k, a) -> Radix.updateL (f a) o $ Radix.feedBytes k) + (\(o, k, a) -> No.updateL (f a) o k) + +updateLWithKeyAdjustT + , updateLWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +updateLWithKeyAdjustT = updateLWithKeyT_ (\a k -> Just . (+ sum (fmap fromIntegral k)) . (+ a)) +updateLWithKeyDeleteT = updateLWithKeyT_ (\_ _ _ -> Nothing) + +updateLWithKeyT_ + :: (Eq a, Integral a) + => (a -> [Word8] -> a -> Maybe a) -> TreeT (No.Openness, [Word8], a) a +updateLWithKeyT_ f = + Test treeEq (\(o, k, a) -> Radix.updateLWithKey (f a . Radix.buildBytes) o $ Radix.feedBytes k) + (\(o, k, a) -> No.updateLWithKey (f a) o k) + +takeLT :: Eq a => TreeT (No.Openness, [Word8]) a +takeLT = Test treeEq (\(o, k) -> Radix.takeL o $ Radix.feedBytes k) + (uncurry No.takeL) + + + +lookupRT :: Eq a => LookupT (No.Openness, [Word8]) a +lookupRT = Test lookupEq (\(o, k) -> Radix.lookupR o $ Radix.feedBytes k) + (uncurry No.lookupR) + +adjustRT, adjustRT' :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +adjustRT = adjustRT_ Radix.adjustR +adjustRT' = adjustRT_ Radix.adjustR' + +adjustRT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> No.Openness -> Radix.Feed -> RadixTree x -> RadixTree x) + -> TreeT (No.Openness, [Word8], a) a +adjustRT_ g = + let f a = (+ a) + in Test treeEq (\(o, k, a) -> g (f a) o $ Radix.feedBytes k) + (\(o, k, a) -> No.adjustR (f a) o k) + +adjustRWithKeyT + , adjustRWithKeyT' + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +adjustRWithKeyT = adjustRWithKeyT_ Radix.adjustRWithKey +adjustRWithKeyT' = adjustRWithKeyT_ Radix.adjustRWithKey' + +adjustRWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Radix.Build -> x -> x) -> No.Openness -> Radix.Feed -> RadixTree x -> RadixTree x) + -> TreeT (No.Openness, [Word8], a) a +adjustRWithKeyT_ g = + let f a k = (+ sum (fmap fromIntegral k)) . (+ a) + in Test treeEq (\(o, k, a) -> g (f a . Radix.buildBytes) o $ Radix.feedBytes k) + (\(o, k, a) -> No.adjustRWithKey (f a) o k) + +updateRAdjustT + , updateRDeleteT + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +updateRAdjustT = updateRT_ (\a -> Just . (+ a)) +updateRDeleteT = updateRT_ (\_ _ -> Nothing) + +updateRT_ + :: (Eq a, Integral a) + => (a -> a -> Maybe a) -> TreeT (No.Openness, [Word8], a) a +updateRT_ f = + Test treeEq (\(o, k, a) -> Radix.updateR (f a) o $ Radix.feedBytes k) + (\(o, k, a) -> No.updateR (f a) o k) + +updateRWithKeyAdjustT + , updateRWithKeyDeleteT + :: (Eq a, Integral a) => TreeT (No.Openness, [Word8], a) a +updateRWithKeyAdjustT = updateRWithKeyT_ (\a k -> Just . (+ sum (fmap fromIntegral k)) . (+ a)) +updateRWithKeyDeleteT = updateRWithKeyT_ (\_ _ _ -> Nothing) + +updateRWithKeyT_ + :: (Eq a, Integral a) + => (a -> [Word8] -> a -> Maybe a) -> TreeT (No.Openness, [Word8], a) a +updateRWithKeyT_ f = + Test treeEq (\(o, k, a) -> Radix.updateRWithKey (f a . Radix.buildBytes) o $ Radix.feedBytes k) + (\(o, k, a) -> No.updateRWithKey (f a) o k) + +takeRT :: Eq a => TreeT (No.Openness, [Word8]) a +takeRT = Test treeEq (\(o, k) -> Radix.takeR o $ Radix.feedBytes k) + (uncurry No.takeR) + + + +lookupMinT :: Eq a => IdT () a (Maybe a) +lookupMinT = Test (==) (\_ -> Radix.lookupMin) (\_ -> No.lookupMin) + +lookupMinWithKeyT :: Eq a => LookupT () a +lookupMinWithKeyT = + Test lookupEq (\_ -> Radix.lookupMinWithKey) (\_ -> No.lookupMinWithKey) + +adjustMinT, adjustMinT' :: (Eq a, Integral a) => TreeT () a +adjustMinT = adjustMinT_ Radix.adjustMin +adjustMinT' = adjustMinT_ Radix.adjustMin' + +adjustMinT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +adjustMinT_ f = Test treeEq (\_ -> f (+ 10000)) (\_ -> No.adjustMin (+ 10000)) + +adjustMinWithKeyT, adjustMinWithKeyT' :: (Eq a, Integral a) => TreeT () a +adjustMinWithKeyT = adjustMinWithKeyT_ Radix.adjustMinWithKey +adjustMinWithKeyT' = adjustMinWithKeyT_ Radix.adjustMinWithKey' + +adjustMinWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Radix.Build -> x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +adjustMinWithKeyT_ g = + let f k = (+ sum (fmap fromIntegral k)) + in Test treeEq (\_ -> g (f . Radix.buildBytes)) (\_ -> No.adjustMinWithKey f) + +deleteMinT :: (Eq a, Integral a) => TreeT () a +deleteMinT = Test treeEq (\_ -> Radix.deleteMin) (\_ -> No.deleteMin) + +updateMinAdjustT, updateMinDeleteT :: (Eq a, Integral a) => TreeT () a +updateMinAdjustT = updateMinT_ (Just . (+ 10000)) +updateMinDeleteT = updateMinT_ (\_ -> Nothing) + +updateMinT_ :: (Eq a, Integral a) => (a -> Maybe a) -> TreeT () a +updateMinT_ f = Test treeEq (\_ -> Radix.updateMin f) (\_ -> No.updateMin f) + +updateMinWithKeyAdjustT, updateMinWithKeyDeleteT :: (Eq a, Integral a) => TreeT () a +updateMinWithKeyAdjustT = updateMinWithKeyT_ (\k -> Just . (+ sum (fmap fromIntegral k))) +updateMinWithKeyDeleteT = updateMinWithKeyT_ (\_ _ -> Nothing) + +updateMinWithKeyT_ :: (Eq a, Integral a) => ([Word8] -> a -> Maybe a) -> TreeT () a +updateMinWithKeyT_ f = + Test treeEq (\_ -> Radix.updateMinWithKey (f . Radix.buildBytes)) + (\_ -> No.updateMinWithKey f) + +minViewT :: Eq a => MinViewT () a +minViewT = Test minViewEq (\_ -> Radix.minView) (\_ -> No.minView) + + + +lookupMaxT :: Eq a => IdT () a (Maybe a) +lookupMaxT = Test (==) (\_ -> Radix.lookupMax) (\_ -> No.lookupMax) + +lookupMaxWithKeyT :: Eq a => LookupT () a +lookupMaxWithKeyT = + Test lookupEq (\_ -> Radix.lookupMaxWithKey) (\_ -> No.lookupMaxWithKey) + +adjustMaxT, adjustMaxT' :: (Eq a, Integral a) => TreeT () a +adjustMaxT = adjustMaxT_ Radix.adjustMax +adjustMaxT' = adjustMaxT_ Radix.adjustMax' + +adjustMaxT_ + :: (Eq a, Integral a) + => (forall x. (x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +adjustMaxT_ f = Test treeEq (\_ -> f (+ 10000)) (\_ -> No.adjustMax (+ 10000)) + +adjustMaxWithKeyT, adjustMaxWithKeyT' :: (Eq a, Integral a) => TreeT () a +adjustMaxWithKeyT = adjustMaxWithKeyT_ Radix.adjustMaxWithKey +adjustMaxWithKeyT' = adjustMaxWithKeyT_ Radix.adjustMaxWithKey' + +adjustMaxWithKeyT_ + :: (Eq a, Integral a) + => (forall x. (Radix.Build -> x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +adjustMaxWithKeyT_ g = + let f k = (+ sum (fmap fromIntegral k)) + in Test treeEq (\_ -> g (f . Radix.buildBytes)) (\_ -> No.adjustMaxWithKey f) + +deleteMaxT :: (Eq a, Integral a) => TreeT () a +deleteMaxT = Test treeEq (\_ -> Radix.deleteMax) (\_ -> No.deleteMax) + +updateMaxAdjustT, updateMaxDeleteT :: (Eq a, Integral a) => TreeT () a +updateMaxAdjustT = updateMaxT_ (Just . (+ 10000)) +updateMaxDeleteT = updateMaxT_ (\_ -> Nothing) + +updateMaxT_ :: (Eq a, Integral a) => (a -> Maybe a) -> TreeT () a +updateMaxT_ f = Test treeEq (\_ -> Radix.updateMax f) (\_ -> No.updateMax f) + +updateMaxWithKeyAdjustT, updateMaxWithKeyDeleteT :: (Eq a, Integral a) => TreeT () a +updateMaxWithKeyAdjustT = updateMaxWithKeyT_ (\k -> Just . (+ sum (fmap fromIntegral k))) +updateMaxWithKeyDeleteT = updateMaxWithKeyT_ (\_ _ -> Nothing) + +updateMaxWithKeyT_ :: (Eq a, Integral a) => ([Word8] -> a -> Maybe a) -> TreeT () a +updateMaxWithKeyT_ f = + Test treeEq (\_ -> Radix.updateMaxWithKey (f . Radix.buildBytes)) + (\_ -> No.updateMaxWithKey f) + +maxViewT :: Eq a => MaxViewT () a +maxViewT = Test maxViewEq (\_ -> Radix.maxView) (\_ -> No.maxView) + + + +filterT :: (Eq a, Integral a) => TreeT () a +filterT = Test treeEq (\_ -> Radix.filter odd) (\_ -> No.filter odd) + +filterWithKeyT :: (Eq a, Integral a) => TreeT () a +filterWithKeyT = + let f k a = odd $ sum (fmap fromIntegral k) + a + in Test treeEq (\_ -> Radix.filterWithKey (f . Radix.buildBytes)) + (\_ -> No.filterWithKey f) + +mapMaybeT :: (Eq a, Integral a) => TreeT () a +mapMaybeT = + let f a | odd a = Nothing + | otherwise = Just a + + in Test treeEq (\_ -> Radix.mapMaybe f) (\_ -> No.mapMaybe f) + +mapMaybeWithKeyT :: (Eq a, Integral a) => TreeT () a +mapMaybeWithKeyT = + let f k a | odd (sum (fmap fromIntegral k) + a) = Nothing + | otherwise = Just a + + in Test treeEq (\_ -> Radix.mapMaybeWithKey (f . Radix.buildBytes)) + (\_ -> No.mapMaybeWithKey f) + +partitionT :: (Eq a, Integral a) => SplitT () a +partitionT = Test splitEq (\_ -> Radix.partition odd) (\_ -> No.partition odd) + +partitionWithKeyT :: (Eq a, Integral a) => SplitT () a +partitionWithKeyT = + let f k a = odd $ sum (fmap fromIntegral k) + a + in Test splitEq (\_ -> Radix.partitionWithKey (f . Radix.buildBytes)) + (\_ -> No.partitionWithKey f) + +mapEitherT :: (Eq a, Integral a) => SplitT () a +mapEitherT = + let f a | odd a = Left a + | otherwise = Right a + + in Test splitEq (\_ -> Radix.mapEither f) (\_ -> No.mapEither f) + +mapEitherWithKeyT :: (Eq a, Integral a) => SplitT () a +mapEitherWithKeyT = + let f k a | odd (sum (fmap fromIntegral k) + a) = Left a + | otherwise = Right a + + in Test splitEq (\_ -> Radix.mapEitherWithKey (f . Radix.buildBytes)) + (\_ -> No.mapEitherWithKey f) + + + +mapT, mapT' :: (Eq a, Num a) => TreeT () a +mapT = mapT_ Radix.map +mapT' = mapT_ Radix.map' + +mapT_ :: (Eq a, Num a) => (forall x. (x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +mapT_ g = + let f = (+ 10000) + in Test treeEq (\_ -> g f) (\_ -> No.map f) + +mapWithKeyT, mapWithKeyT' :: (Eq a, Num a) => TreeT () a +mapWithKeyT = mapWithKeyT_ Radix.mapWithKey +mapWithKeyT' = mapWithKeyT_ Radix.mapWithKey' + +mapWithKeyT_ + :: (Eq a, Num a) + => (forall x. (Radix.Build -> x -> x) -> RadixTree x -> RadixTree x) -> TreeT () a +mapWithKeyT_ g = + let f k = (+ sum (fmap fromIntegral k)) . (+ 10000) + in Test treeEq (\_ -> g (f . Radix.buildBytes)) (\_ -> No.mapWithKey f) + + +foldlT, foldlT' :: (Eq a, Num a) => IdT () a [a] +foldlT = foldlT_ Radix.foldl +foldlT' = foldlT_ Radix.foldl' + +foldlT_ :: Eq a => (forall x. (x -> a -> x) -> x -> RadixTree a -> x) -> IdT () a [a] +foldlT_ g = + Test (==) (\_ -> g (flip (:)) []) (\_ -> No.foldl (flip (:)) []) + +foldlWithKeyT, foldlWithKeyT' :: Eq a => IdT () a [([Word8], a)] +foldlWithKeyT = foldlWithKeyT_ Radix.foldlWithKey +foldlWithKeyT' = foldlWithKeyT_ Radix.foldlWithKey' + +foldlWithKeyT_ + :: Eq a + => (forall x. (x -> Radix.Build -> a -> x) -> x -> RadixTree a -> x) + -> IdT () a [([Word8], a)] +foldlWithKeyT_ g = + Test (==) (\_ -> g (\z k a -> (Radix.buildBytes k, a) : z) []) + (\_ -> No.foldlWithKey (\z k a -> (k, a) : z) []) + + + +foldrT, foldrT' :: Eq a => IdT () a [a] +foldrT = foldrT_ Radix.foldr +foldrT' = foldrT_ Radix.foldr' + +foldrT_ :: Eq a => (forall x. (a -> x -> x) -> x -> RadixTree a -> x) -> IdT () a [a] +foldrT_ g = Test (==) (\_ -> g (:) []) (\_ -> No.foldr (:) []) + +foldrWithKeyT, foldrWithKeyT' :: (Eq a, Num a) => IdT () a [([Word8], a)] +foldrWithKeyT = foldrWithKeyT_ Radix.foldrWithKey +foldrWithKeyT' = foldrWithKeyT_ Radix.foldrWithKey' + +foldrWithKeyT_ + :: (Eq a, Num a) + => (forall y. (Radix.Build -> a -> y -> y) -> y -> RadixTree a -> y) + -> IdT () a [([Word8], a)] +foldrWithKeyT_ g = Test (==) (\_ -> g (\k a -> (:) (Radix.buildBytes k, a)) []) + (\_ -> No.foldrWithKey (\k a -> (:) (k, a)) []) + + + +foldMapT :: Eq a => IdT () a [a] +foldMapT = Test (==) (\_ -> Radix.foldMap (:[])) (\_ -> No.foldMap (:[])) + +foldMapWithKeyT :: Eq a => IdT () a [([Word8], a)] +foldMapWithKeyT = + Test (==) (\_ -> Radix.foldMapWithKey (\k a -> [(Radix.buildBytes k, a)])) + (\_ -> No.foldMapWithKey (\k a -> [(k, a)])) + + + +idTreeEq :: Eq a => Identity (RadixTree a) -> Identity (NoTree [Word8] a) -> Bool +idTreeEq (Identity a) (Identity b) = treeEq a b + +traverseT + :: (Eq a, Num a) + => Test s (RadixTree a) (NoTree [Word8] a) + (Identity (RadixTree a)) (Identity (NoTree [Word8] a)) +traverseT = + let f = Identity . (+ 10000) + in Test idTreeEq (\_ -> Radix.traverse f) (\_ -> No.traverse f) + +traverseWithKeyT + :: (Eq a, Num a) + => Test s (RadixTree a) (NoTree [Word8] a) + (Identity (RadixTree a)) (Identity (NoTree [Word8] a)) +traverseWithKeyT = + let f k a = Identity $ sum (fmap fromIntegral k) + 10000 + a + in Test idTreeEq (\_ -> Radix.traverseWithKey (f . Radix.buildBytes)) + (\_ -> No.traverseWithKey f) + + + +unionT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +unionT = Test treeEq (Radix.union . fst) (No.unionL . snd) + +unionLT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +unionLT = Test treeEq (Radix.unionL . fst) (No.unionL . snd) + +unionWithT' :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +unionWithT' = Test treeEq (Radix.unionWith' (\_ y -> y) . fst) + (No.unionWithKey (\_ _ y -> y) . snd) + +unionWithKeyT', mergeUnionT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +unionWithKeyT' = unionWithKeyT_ Radix.unionWithKey' +mergeUnionT = + unionWithKeyT_ $ \f -> + Radix.merge (\k a b -> Just $! f k a b) + (\_ -> Just) (\_ -> id) (\_ -> Just) (\_ -> id) + +unionWithKeyT_ + :: Eq a + => ((Radix.Build -> a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a) + -> TreeT (RadixTree a, NoTree [Word8] a) a +unionWithKeyT_ g = + let f k a b | odd $ sum (fmap (fromIntegral :: Word8 -> Int) k) = a + | otherwise = b + + in Test treeEq (g (f . Radix.buildBytes) . fst) + (No.unionWithKey f . snd) + + + +differenceT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +differenceT = Test treeEq (Radix.difference . fst) (No.difference . snd) + +differenceWithT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +differenceWithT = Test treeEq (Radix.differenceWith (\_ -> Just) . fst) + (No.differenceWithKey (\_ _ -> Just) . snd) + +differenceWithKeyT + , mergeDifferenceT + :: (Eq a, Integral a) => TreeT (RadixTree a, NoTree [Word8] a) a +differenceWithKeyT = differenceWithKeyT_ Radix.differenceWithKey +mergeDifferenceT = + differenceWithKeyT_ $ \f -> + Radix.merge f (\_ -> Just) (\_ -> id) (\_ _ -> Nothing) (\_ _ -> Radix1.empty) + +differenceWithKeyT_ + :: (Eq a, Integral a) + => ((Radix.Build -> a -> a -> Maybe a) -> RadixTree a -> RadixTree a -> RadixTree a) + -> TreeT (RadixTree a, NoTree [Word8] a) a +differenceWithKeyT_ g = + let f k a b | odd $ sum (fmap (fromIntegral :: Word8 -> Int) k) = Just a + | otherwise = if even b + then Just b + else Nothing + in Test treeEq (g (f . Radix.buildBytes) . fst) + (No.differenceWithKey f . snd) + + + +disjointT :: Eq a => IdT (RadixTree a, NoTree [Word8] a) a Bool +disjointT = Test (==) (Radix.disjoint . fst) (\(_, a) -> No.null . No.intersectionL a) + +intersectionT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +intersectionT = Test treeEq (Radix.intersection . fst) (No.intersectionL . snd) + +intersectionLT :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +intersectionLT = Test treeEq (Radix.intersectionL . fst) (No.intersectionL . snd) + +intersectionWithT' :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +intersectionWithT' = Test treeEq (Radix.intersectionWith' (\_ y -> y) . fst) + (No.intersectionWithKey (\_ _ y -> y) . snd) + +intersectionWithKeyT' + , mergeIntersectionT + :: Eq a => TreeT (RadixTree a, NoTree [Word8] a) a +intersectionWithKeyT' = intersectionWithKeyT_ Radix.intersectionWithKey' +mergeIntersectionT = + intersectionWithKeyT_ $ \f -> + Radix.merge (\k a b -> Just $! f k a b) + (\_ _ -> Nothing) (\_ _ -> Radix1.empty) (\_ _ -> Nothing) (\_ _ -> Radix1.empty) + +intersectionWithKeyT_ + :: Eq a + => ((Radix.Build -> a -> a -> a) -> RadixTree a -> RadixTree a -> RadixTree a) + -> TreeT (RadixTree a, NoTree [Word8] a) a +intersectionWithKeyT_ g = + let f k a b | odd $ sum (fmap (fromIntegral :: Word8 -> Int) k) = a + | otherwise = b + + in Test treeEq (g (f . Radix.buildBytes) . fst) + (No.intersectionWithKey f . snd) + + + +compareT :: Eq a => IdT (RadixTree a, NoTree [Word8] a) a Radix.PartialOrdering +compareT = Test (==) (Radix.compare (==) . fst) (No.compare . snd) + + + +test :: Spec +test = do + describe "Single-key" $ do + it "lookup" $ run unary1_ lookupT + it "find" $ run unary1 findT + it "member" $ run unary1_ memberT + it "subtree" $ run unary1_ subtreeT + it "move/single" $ run unary1_ moveSingleT + it "move/thirds" $ run unary1_ moveThirdsT + it "insert" $ run unary1 insertT + it "insertWith" $ run unary1 insertWithT + it "insertWith'" $ run unary1 insertWithT' + it "adjust" $ run unary1 adjustT + it "adjust'" $ run unary1 adjustT' + it "delete" $ run unary1_ deleteT + it "prune" $ run unary1R pruneT + it "update/adjust" $ run unary1 updateAdjustT + it "update/delete" $ run unary1 updateDeleteT + it "alter/insert" $ run unary1 alterInsertT + it "alter/insertWith" $ run unary1 alterInsertWithT + it "alter/adjust" $ run unary1 alterAdjustT + it "alter/delete" $ run unary1 alterDeleteT + it "shape/insert" $ run unary1_ shapeInsertT + it "shape/adjust" $ run unary1_ shapeAdjustT + it "shape/filter" $ run unary1_ shapeFilterT + it "shape/delete" $ run unary1_ shapeDeleteT + + describe "Split" $ do + it "splitL" $ run unary1R splitLT + it "splitLookup" $ run unary1_ splitLookupT + + describe "Left" $ do + it "lookupL" $ run unary1R lookupLT + it "adjustL" $ run unary1F adjustLT + it "adjustL'" $ run unary1F adjustLT' + it "adjustLWithKey" $ run unary1F adjustLWithKeyT + it "adjustLWithKey'" $ run unary1F adjustLWithKeyT' + it "updateL/adjust" $ run unary1F updateLAdjustT + it "updateL/delete" $ run unary1F updateLDeleteT + it "updateLWithKey/adjust" $ run unary1F updateLWithKeyAdjustT + it "updateLWithKey/delete" $ run unary1F updateLWithKeyDeleteT + it "takeL" $ run unary1R takeLT + + describe "Right" $ do + it "lookupR" $ run unary1R lookupRT + it "adjustR" $ run unary1F adjustRT + it "adjustR'" $ run unary1F adjustRT' + it "adjustRWithKey" $ run unary1F adjustRWithKeyT + it "adjustRWithKey'" $ run unary1F adjustRWithKeyT' + it "updateR/adjust" $ run unary1F updateRAdjustT + it "updateR/delete" $ run unary1F updateRDeleteT + it "updateRWithKey/adjust" $ run unary1F updateRWithKeyAdjustT + it "updateRWithKey/delete" $ run unary1F updateRWithKeyDeleteT + it "takeR" $ run unary1R takeRT + + describe "Min" $ do + it "lookupMin" $ run unary0 lookupMinT + it "lookupMinWithKey" $ run unary0 lookupMinWithKeyT + it "adjustMin" $ run unary0 adjustMinT + it "adjustMinWithKey" $ run unary0 adjustMinWithKeyT + it "adjustMin'" $ run unary0 adjustMinT' + it "adjustMinWithKey'" $ run unary0 adjustMinWithKeyT' + it "deleteMin" $ run unary0 deleteMinT + it "updateMin/adjust" $ run unary0 updateMinAdjustT + it "updateMin/delete" $ run unary0 updateMinDeleteT + it "updateMinWithKey/adjust" $ run unary0 updateMinWithKeyAdjustT + it "updateMinWithKey/delete" $ run unary0 updateMinWithKeyDeleteT + it "minView" $ run unary0 minViewT + + describe "Max" $ do + it "lookupMax" $ run unary0 lookupMaxT + it "lookupMaxWithKey" $ run unary0 lookupMaxWithKeyT + it "adjustMax" $ run unary0 adjustMaxT + it "adjustMaxWithKey" $ run unary0 adjustMaxWithKeyT + it "adjustMax'" $ run unary0 adjustMaxT' + it "adjustMaxWithKey'" $ run unary0 adjustMaxWithKeyT' + it "deleteMax" $ run unary0 deleteMaxT + it "updateMax/adjust" $ run unary0 updateMaxAdjustT + it "updateMax/delete" $ run unary0 updateMaxDeleteT + it "updateMaxWithKey/adjust" $ run unary0 updateMaxWithKeyAdjustT + it "updateMaxWithKey/delete" $ run unary0 updateMaxWithKeyDeleteT + it "maxView" $ run unary0 maxViewT + + describe "Partition" $ do + it "filter" $ run unary0 filterT + it "filterWithKey" $ run unary0 filterWithKeyT + it "mapMaybe" $ run unary0 mapMaybeT + it "mapMaybeWithKey" $ run unary0 mapMaybeWithKeyT + it "partition" $ run unary0 partitionT + it "partitionWithKey" $ run unary0 partitionWithKeyT + it "mapEither" $ run unary0 mapEitherT + it "mapEitherWithKey" $ run unary0 mapEitherWithKeyT + + describe "Full-tree" $ do + it "prefix" $ run unary1_ prefixT + it "map" $ run unary0 mapT + it "map'" $ run unary0 mapT' + it "mapWithKey" $ run unary0 mapWithKeyT + it "mapWithKey'" $ run unary0 mapWithKeyT' + it "foldl" $ run unary0 foldlT + it "foldl'" $ run unary0 foldlT' + it "foldlWithKey" $ run unary0 foldlWithKeyT + it "foldlWithKey'" $ run unary0 foldlWithKeyT' + it "foldr" $ run unary0 foldrT + it "foldr'" $ run unary0 foldrT' + it "foldrWithKey" $ run unary0 foldrWithKeyT + it "foldrWithKey'" $ run unary0 foldrWithKeyT' + it "foldMap" $ run unary0 foldMapT + it "foldMapWithKey" $ run unary0 foldMapWithKeyT + it "traverse" $ run unary0 traverseT + it "traverseWithKey" $ run unary0 traverseWithKeyT + + describe "Merge" $ do + it "union" $ run binary unionT + it "unionL" $ run binaryL unionLT + it "unionWith'" $ run binaryL unionWithT' + it "unionWithKey'" $ run binaryL unionWithKeyT' + it "difference" $ run binaryL differenceT + it "differenceWith" $ run binaryL differenceWithT + it "differenceWithKey" $ run binaryL differenceWithKeyT + it "disjoint/yes" $ run binary disjointT + it "disjoint/no" $ run binaryL disjointT + it "intersection" $ run binary intersectionT + it "intersectionL" $ run binaryL intersectionLT + it "intersectionWith'" $ run binaryL intersectionWithT' + it "intersectionWithKey'" $ run binaryL intersectionWithKeyT' + it "compare/subset" $ run subset compareT + it "compare/superset" $ run superset compareT + it "compare/equal" $ run equal compareT + it "compare/incomparable" $ run binary compareT + it "merge/union" $ run binaryL mergeUnionT + it "merge/difference" $ run binaryL mergeDifferenceT + it "merge/intersection" $ run binaryL mergeIntersectionT diff --git a/test/properties/Test/Random.hs b/test/properties/Test/Random.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/Random.hs @@ -0,0 +1,42 @@ +module Test.Random + ( list + , list1 + , shuffle + ) where + +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import System.Random + + + +list :: (g -> (a, g)) -> Int -> g -> ([a], g) +list gen = go + where + go n g + | n <= 0 = ([], g) + | otherwise = let ~(a, g') = gen g + ~(as, g'') = go (n - 1) g' + in (a:as, g'') + +list1 :: (g -> (a, g)) -> Int -> g -> (NonEmpty a, g) +list1 gen n g = + let ~(a, g') = gen g + in if n <= 1 + then (a :| [], g') + else let ~(as, g'') = list gen (n - 1) g' + in (a :| as, g'') + + + +shuffle :: RandomGen g => [a] -> g -> ([a], g) +shuffle as g = let ~(bs, g') = ziplist as g + in (fmap snd $ sortBy (\a b -> fst a `compare` fst b) bs, g') + where + ziplist :: RandomGen g => [a] -> g -> ([(Int, a)], g) + ziplist xs h = + case xs of + [] -> ([], h) + x:ys -> let ~(n, h') = uniform h + ~(zs, h'') = ziplist ys h' + in ((n, x):zs, h'') diff --git a/test/properties/Test/Zebra/Word.hs b/test/properties/Test/Zebra/Word.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/Zebra/Word.hs @@ -0,0 +1,344 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.Zebra.Word + ( test + ) where + +import Data.Zebra.Word (Zebra, Color (..), Range (..)) +import qualified Data.Zebra.Word as Zebra +import Data.Zebra.Word.Debug +import No.Set.Word (NoSet) +import qualified No.Set.Word as No +import Test.Kit +import Test.Zebra.Word.Sample + +import Numeric.Natural +import Test.Hspec + + + +setFromList :: Color -> ((Word -> Color -> Zebra -> Zebra) -> Zebra -> a) -> a +setFromList c f = f Zebra.fillL (Zebra.Mono c) + +setToList :: Zebra -> [(Color, Word, Word)] +setToList = Zebra.foldr (\(Range kL kR) c -> (:) (c, kL, kR)) [] + +noToList :: NoSet -> [(Color, Word, Word)] +noToList = No.foldr (\(Range kL kR) c -> (:) (c, kL, kR)) [] + + + +unary0 :: [Case () Zebra NoSet] +unary0 = foldMap (mkUnary0 setFromList) [zero, one, tiny, small, medium] --, large] + + + +unary1 :: [Case (Word, Color) Zebra NoSet] +unary1 = foldMap (mkUnary1 setFromList) [zero, one, tiny, small, medium] --, large] + +unary1_ :: [Case Word Zebra NoSet] +unary1_ = augment fst unary1 + + +unary2 :: [Case (Range, Color) Zebra NoSet] +unary2 = foldMap (mkUnary2 setFromList) [zero, one, tiny, small, medium] --, large] + +unary2_ :: [Case Range Zebra NoSet] +unary2_ = augment fst unary2 + + + +binaryL, equal :: [Case (Zebra, NoSet) Zebra NoSet] +binaryL = foldMap (mkBinaryL setFromList) [zero, one, tiny, small, medium] --, large] +equal = foldMap (mkEqual setFromList) [zero, one, tiny, small, medium] --, large] + +subset :: Color -> [Case (Zebra, NoSet) Zebra NoSet] +subset c = foldMap (mkSubset setFromList c) [zero, one, tiny, small, medium] --, large] + + + +-- Tip/Tip combinations. +_tipTip :: [Case (Zebra, NoSet) Zebra NoSet] +_tipTip = foldMap (\(a, b, c, d) -> mkTipTip setFromList a b c d) tipsA + +-- Tip/Bin combinations. +_tipBin :: [Case (Zebra, NoSet) Zebra NoSet] +_tipBin = foldMap (\(a, b, s) -> mkTipBin setFromList a b s) tipsB + + + +type IdT s b = Test s Zebra NoSet b b + +type TreeT s = Test s Zebra NoSet Zebra NoSet + +treeEq :: Zebra -> NoSet -> Bool +treeEq set no = + case validate set of + Valid -> setToList set == noToList no + _ -> False + + + +lookupT :: IdT Word Color +lookupT = Test (==) Zebra.lookup No.lookup + +lookupLT :: IdT (Word, Color) (Maybe Word) +lookupLT = Test (==) (\(k, c) -> Zebra.lookupL c k) + (\(k, c) -> No.lookupL c k) + +findLT :: IdT (Word, Color) Word +findLT = Test (==) (\(k, c) -> Zebra.findL (maxBound - 5) c k) + (\(k, c) -> No.findL (maxBound - 5) c k) + +lookupRT :: IdT (Word, Color) (Maybe Word) +lookupRT = Test (==) (\(k, c) -> Zebra.lookupR c k) + (\(k, c) -> No.lookupR c k) + +findRT :: IdT (Word, Color) Word +findRT = Test (==) (\(k, c) -> Zebra.findR (maxBound - 5) c k) + (\(k, c) -> No.findR (maxBound - 5) c k) + + + +monoT :: IdT () (Maybe Color) +monoT = Test (==) ( \_ t -> case t of + Zebra.Mono c -> Just c + _ -> Nothing + ) + ( \_ t -> case t of + No.Mono c -> Just c + _ -> Nothing + ) + +monoLT :: IdT Word (Maybe Color) +monoLT = Test (==) Zebra.monoL No.monoL + +monoRT :: IdT Word (Maybe Color) +monoRT = Test (==) Zebra.monoR No.monoR + +monoRangeT :: IdT Range (Maybe Color) +monoRangeT = Test (==) Zebra.monoRange No.monoRange + + + +sizeT :: No.Color -> IdT () Natural +sizeT c = Test (==) (\_ -> Zebra.size c) (\_ -> No.size c) + +sizeLT :: IdT (Word, Color) Natural +sizeLT = Test (==) (uncurry $ flip Zebra.sizeL) (uncurry $ flip No.sizeL) + +sizeRT :: IdT (Word, Color) Natural +sizeRT = Test (==) (uncurry $ flip Zebra.sizeR) (uncurry $ flip No.sizeR) + +sizeRangeT :: IdT (Range, Color) Natural +sizeRangeT = Test (==) (uncurry $ flip Zebra.sizeRange) (uncurry $ flip No.sizeRange) + + + +fillLT :: TreeT (Word, Color) +fillLT = Test treeEq (uncurry Zebra.fillL) (uncurry No.fillL) + +fillRT :: TreeT (Word, Color) +fillRT = Test treeEq (uncurry Zebra.fillR) (uncurry No.fillR) + +fillRangeT :: TreeT (Range, Color) +fillRangeT = Test treeEq (uncurry Zebra.fillRange) (uncurry No.fillRange) + + + +complementT :: TreeT () +complementT = Test treeEq (\_ -> Zebra.complement) (\_ -> No.complement) + + + +foldlT, foldlT' :: IdT () [(Color, Word, Word)] +foldlT = foldlT_ Zebra.foldl +foldlT' = foldlT_ Zebra.foldl' + +foldlT_ + :: (forall x. (x -> Range -> Color -> x) -> x -> Zebra -> x) + -> IdT () [(Color, Word, Word)] +foldlT_ g = + let f z (Range kL kR) c = (c, kL, kR) : z + in Test (==) (\_ -> g f []) (\_ -> No.foldl f []) + + +foldlLT, foldlLT' :: IdT Word [(Color, Word, Word)] +foldlLT = foldlLT_ Zebra.foldlL +foldlLT' = foldlLT_ Zebra.foldlL' + +foldlLT_ + :: (forall x. Word -> (x -> Range -> Color -> x) -> x -> Zebra -> x) + -> IdT Word [(Color, Word, Word)] +foldlLT_ g = + let f z (Range kL kR) c = (c, kL, kR) : z + in Test (==) (\w -> g w f []) (\w -> No.foldlL w f []) + + +foldlRT, foldlRT' :: IdT Word [(Color, Word, Word)] +foldlRT = foldlRT_ Zebra.foldlR +foldlRT' = foldlRT_ Zebra.foldlR' + +foldlRT_ + :: (forall x. Word -> (x -> Range -> Color -> x) -> x -> Zebra -> x) + -> IdT Word [(Color, Word, Word)] +foldlRT_ g = + let f z (Range kL kR) c = (c, kL, kR) : z + in Test (==) (\w -> g w f []) (\w -> No.foldlR w f []) + + +foldlRangeT, foldlRangeT' :: IdT Range [(Color, Word, Word)] +foldlRangeT = foldlRangeT_ Zebra.foldlRange +foldlRangeT' = foldlRangeT_ Zebra.foldlRange' + +foldlRangeT_ + :: (forall x. Range -> (x -> Range -> Color -> x) -> x -> Zebra -> x) + -> IdT Range [(Color, Word, Word)] +foldlRangeT_ g = + let f z (Range kL kR) c = (c, kL, kR) : z + in Test (==) (\w -> g w f []) (\w -> No.foldlRange w f []) + + + +foldrT, foldrT' :: IdT () [(Color, Word, Word)] +foldrT = foldrT_ Zebra.foldr +foldrT' = foldrT_ Zebra.foldr' + +foldrT_ + :: (forall x. (Range -> Color -> x -> x) -> x -> Zebra -> x) + -> IdT () [(Color, Word, Word)] +foldrT_ g = + let f (Range kL kR) c = (:) (c, kL, kR) + in Test (==) (\_ -> g f []) (\_ -> No.foldr f []) + + +foldrLT, foldrLT' :: IdT Word [(Color, Word, Word)] +foldrLT = foldrLT_ Zebra.foldrL +foldrLT' = foldrLT_ Zebra.foldrL' + +foldrLT_ + :: (forall x. Word -> (Range -> Color -> x -> x) -> x -> Zebra -> x) + -> IdT Word [(Color, Word, Word)] +foldrLT_ g = + let f (Range kL kR) c = (:) (c, kL, kR) + in Test (==) (\w -> g w f []) (\w -> No.foldrL w f []) + + +foldrRT, foldrRT' :: IdT Word [(Color, Word, Word)] +foldrRT = foldrRT_ Zebra.foldrR +foldrRT' = foldrRT_ Zebra.foldrR' + +foldrRT_ + :: (forall x. Word -> (Range -> Color -> x -> x) -> x -> Zebra -> x) + -> IdT Word [(Color, Word, Word)] +foldrRT_ g = + let f (Range kL kR) c = (:) (c, kL, kR) + in Test (==) (\w -> g w f []) (\w -> No.foldrR w f []) + + + +foldrRangeT, foldrRangeT' :: IdT Range [(Color, Word, Word)] +foldrRangeT = foldrRangeT_ Zebra.foldrRange +foldrRangeT' = foldrRangeT_ Zebra.foldrRange' + +foldrRangeT_ + :: (forall x. Range -> (Range -> Color -> x -> x) -> x -> Zebra -> x) + -> IdT Range [(Color, Word, Word)] +foldrRangeT_ g = + let f (Range kL kR) c = (:) (c, kL, kR) + in Test (==) (\w -> g w f []) (\w -> No.foldrRange w f []) + + + +unionT :: Color -> TreeT (Zebra, NoSet) +unionT c = Test treeEq (Zebra.union c . fst) (No.union c . snd) + +intersectionT :: Color -> TreeT (Zebra, NoSet) +intersectionT c = Test treeEq (Zebra.intersection c . fst) (No.intersection c . snd) + +disjointT :: Color -> IdT (Zebra, NoSet) Bool +disjointT c = Test (==) (Zebra.disjoint c . fst) (No.disjoint c . snd) + + + +differenceT :: Color -> TreeT (Zebra, NoSet) +differenceT c = Test treeEq (Zebra.difference c . fst) + (No.difference c . snd) + +symmetricDifferenceT :: Color -> TreeT (Zebra, NoSet) +symmetricDifferenceT c = Test treeEq (Zebra.symmetricDifference c . fst) + (No.symmetricDifference c . snd) + + + +compareT :: Color -> IdT (Zebra, NoSet) No.PartialOrdering +compareT c = Test (==) (Zebra.compare c . fst) (No.compare c . snd) + + + +test :: Spec +test = do + describe "Single-key" $ do + it "lookup" $ run unary1_ lookupT + + describe "Left" $ do + it "monoL" $ run unary1_ monoLT + it "sizeL" $ run unary1 sizeLT + it "lookupL" $ run unary1 lookupLT + it "findL" $ run unary1 findLT + it "fillL" $ run unary1 fillLT + it "foldlL" $ run unary1_ foldlLT + it "foldlL'" $ run unary1_ foldlLT' + it "foldrL" $ run unary1_ foldrLT + it "foldrL'" $ run unary1_ foldrLT' + + describe "Right" $ do + it "monoR" $ run unary1_ monoRT + it "sizeR" $ run unary1 sizeRT + it "lookupR" $ run unary1 lookupRT + it "findR" $ run unary1 findRT + it "fillR" $ run unary1 fillRT + it "foldlR" $ run unary1_ foldlRT + it "foldlR'" $ run unary1_ foldlRT' + it "foldrR" $ run unary1_ foldrRT + it "foldrR'" $ run unary1_ foldrRT' + + describe "Range" $ do + it "monoRange" $ run unary2_ monoRangeT + it "sizeRange" $ run unary2 sizeRangeT + it "fillRange" $ run unary2 fillRangeT + it "foldlRange" $ run unary2_ foldlRangeT + it "foldlRange'" $ run unary2_ foldlRangeT' + it "foldrRange" $ run unary2_ foldrRangeT + it "foldrRange'" $ run unary2_ foldrRangeT' + + describe "Full-tree" $ do + it "Mono" $ run unary0 monoT + it "size/White" $ run unary0 (sizeT White) + it "size/Black" $ run unary0 (sizeT Black) + it "foldl" $ run unary0 foldlT + it "foldl'" $ run unary0 foldlT' + it "foldr" $ run unary0 foldrT + it "foldr'" $ run unary0 foldrT' + + describe "Merge" $ do + it "complement" $ run unary0 complementT + it "union/White" $ run binaryL (unionT White) + it "union/Black" $ run binaryL (unionT Black) + it "disjoint/White" $ run binaryL (disjointT White) + it "disjoint/Black" $ run binaryL (disjointT Black) + it "intersection/White" $ run binaryL (intersectionT White) + it "intersection/Black" $ run binaryL (intersectionT Black) + it "difference/White" $ run binaryL (differenceT White) + it "difference/Black" $ run binaryL (differenceT Black) + it "symmetricDifference/White" $ run binaryL (symmetricDifferenceT White) + it "symmetricDifference/Black" $ run binaryL (symmetricDifferenceT Black) + + it "compare/incomparable/White" $ run binaryL (compareT White) + it "compare/incomparable/Black" $ run binaryL (compareT Black) + it "compare/equal/White" $ run equal (compareT White) + it "compare/equal/Black" $ run equal (compareT Black) + it "compare/subset/White" $ run (subset White) (compareT White) + it "compare/subset/Black" $ run (subset Black) (compareT Black) + it "compare/superset/White" $ run (subset Black) (compareT White) + it "compare/superset/Black" $ run (subset White) (compareT Black) diff --git a/test/properties/Test/Zebra/Word/Sample.hs b/test/properties/Test/Zebra/Word/Sample.hs new file mode 100644 --- /dev/null +++ b/test/properties/Test/Zebra/Word/Sample.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.Zebra.Word.Sample + ( Sample + , zero + , one + , tiny + , small + , medium + , large + + , mkUnary0 + , mkUnary1 + , mkUnary2 + + , mkBinaryL + , mkEqual + , mkSubset + + , tipsA + , mkTipTip + , tipsB + , mkTipBin + ) where + +import No.Set.Word (NoSet) +import qualified No.Set.Word as No +import Test.Kit +import Test.Random + +import Data.Foldable (foldl') +import Data.Function +import qualified Data.List as List +import System.Random + + + +data Sample = Sample + No.Color -- ^ Color of negative infinity in the set + [(Word, No.Color)] -- ^ Keys in the set (colors are arbitrary) + [(Word, No.Color)] -- ^ Keys not in the set (colors are arbitrary) + deriving Show + +zero, one :: Sample +zero = Sample No.Black [] + [ (0, No.Black), (5824, No.White), (6183, No.Black), (maxBound, No.White) + ] + +one = Sample No.White [(6593, No.Black)] + [ (0 , No.Black), (4905, No.White), (6285, No.Black), (6134 , No.White) + , (6737, No.Black), (6928, No.White), (7513, No.Black), (maxBound, No.White) + ] + + + +halve :: [a] -> ([a], [a]) +halve (a:b:cs) = let ~(xs, ys) = halve cs + in (a:xs, b:ys) +halve a = (a, []) + +color :: Bool -> No.Color +color False = No.Black +color True = No.White + +sample :: RandomGen g => (Word, Word) -> Int -> g -> (Sample, g) +sample r n g0 = + let ~(c0, g1) = uniform g0 + + ~(xs, g2) = list (\g' -> let ~(w, g'') = uniformR r g' + ~(c, _) = uniform g'' + + in ((w, color c), g'') + ) + n g1 + + cs = List.nub $ List.sortBy (compare `on` fst) xs + + ~(as, bs) = halve cs + + in (Sample (color c0) as bs, g2) + + + +-- | Function that fills the space in the \((+\infty, k]\) range with the given color. +type FillL set = Word -> No.Color -> set -> set + +type FromList set = No.Color + -- ^ Color of positive infinity + + -> (FillL set -> set -> set) + -- ^ Application of every other color. + + -> set + +foldrFromList :: FromList set -> No.Color -> [(Word, No.Color)] -> set +foldrFromList f c xs = f c (\g s0 -> List.foldr (uncurry g) s0 xs) + +noFromList :: FromList NoSet +noFromList c f = f No.fillL (No.Mono c) + +setFromNo :: Show set => FromList set -> NoSet -> set +setFromNo setFromList no = + case No.foldl (\z r c -> (r, c) : z) [] no of + [] -> error "Zebra.Sample: empty NoSet" + (_, c) : ys -> setFromList c $ \f s -> foldl' (\z (No.Range _ b, x) -> f b x z) s ys + +tiny, small, medium, large :: Sample +tiny = fst $ sample (0x1000, 0x80000) 8 (mkStdGen 0) +small = fst $ sample (0x1000, 0x80000) 64 (mkStdGen 1) +medium = fst $ sample (0x1000, 0x80000) 512 (mkStdGen 2) +large = fst $ sample (0x1000, 0x80000) 4096 (mkStdGen 3) + + + +mkUnary0 :: FromList set -> Sample -> [Case () set NoSet] +mkUnary0 setFromList (Sample c xs _) = + [Case () (foldrFromList setFromList c xs) (foldrFromList noFromList c xs)] + +mkUnary1 :: FromList set -> Sample -> [Case (Word, No.Color) set NoSet] +mkUnary1 setFromList (Sample c xs ys) = + let set = foldrFromList setFromList c xs + no = foldrFromList noFromList c xs + + in foldr (\x -> (:) (Case x set no)) [] $ + (:) (0, No.Black) . (:) (maxBound, No.White) $ xs <> ys + +mkUnary2 :: FromList set -> Sample -> [Case (No.Range, No.Color) set NoSet] +mkUnary2 setFromList (Sample c xs ys) = + let set = foldrFromList setFromList c xs + no = foldrFromList noFromList c xs + + ~(as, bs) = halve xs + ~(cs, ds) = halve ys + + ones = fmap (\(a, i) -> (No.UnsafeRange a a, i)) $ + (:) (0, No.White) . (:) (maxBound, No.Black) $ as <> cs + + es = List.nub . List.sortBy (compare `on` fst) $ bs <> ds + + twos = (:) (No.UnsafeRange 0 0x65432 , No.Black) + . (:) (No.UnsafeRange 0x54321 maxBound, No.White) + . (:) (No.UnsafeRange 0 maxBound, No.White) + $ unsafeRanges es + + in foldr (\x -> (:) (Case x set no)) [] $ ones <> twos + where + -- | Converts an ascending list of integers into a list of ranges. + unsafeRanges :: [(Word, No.Color)] -> [(No.Range, No.Color)] + unsafeRanges ((a, x):(b, _):cs) = (No.UnsafeRange a b, x) : unsafeRanges cs + unsafeRanges _ = [] + + + +mkBinaryL :: FromList set -> Sample -> [Case (set, NoSet) set NoSet] +mkBinaryL setFromList (Sample c xs ys) = + let set1 = foldrFromList setFromList c xs + no1 = foldrFromList noFromList c xs + + set2 = foldrFromList setFromList c ys + no2 = foldrFromList noFromList c ys + + in [Case (set2, no2) set1 no1] + + +mkEqual :: FromList set -> Sample -> [Case (set, NoSet) set NoSet] +mkEqual setFromList (Sample c xs _) = + let set = foldrFromList setFromList c xs + no = foldrFromList noFromList c xs + + in [Case (set, no) set no] + +mkSubset :: Show set => FromList set -> No.Color -> Sample -> [Case (set, NoSet) set NoSet] +mkSubset setFromList x (Sample c xs ys) = + let set = foldrFromList setFromList c xs + + no = foldrFromList noFromList c xs + no' = foldrFromList noFromList c ys + + noI = No.intersection x no no' + + in [Case (setFromNo setFromList noI, noI) set no] + + + +tipA :: RandomGen g => g -> ((No.Color, Word, No.Color, Word), g) +tipA g0 = + let ~(c1, g1) = uniform g0 + ~(w1, g2) = uniform g1 + + ~(c2, g3) = uniform g2 + ~(w2, g4) = uniform g3 + + in ((if c1 then No.White else No.Black, w1, if c2 then No.White else No.Black, w2), g4) + +tipsA :: [(No.Color, Word, No.Color, Word)] +tipsA = fst $ list tipA 10000 (mkStdGen 0) + +mkTipTip :: FromList set -> No.Color -> Word -> No.Color -> Word -> [Case (set, NoSet) set NoSet] +mkTipTip setFromList c1 w1 c2 w2 = + let set1 = foldrFromList setFromList c1 [(w1, No.other c1)] + no1 = foldrFromList noFromList c1 [(w1, No.other c1)] + + set2 = foldrFromList setFromList c2 [(w2, No.other c2)] + no2 = foldrFromList noFromList c2 [(w2, No.other c2)] + + in [Case (set2, no2) set1 no1] + + + +tipB :: RandomGen g => g -> ((No.Color, Word, Sample), g) +tipB g0 = + let ~(c1, g1) = uniform g0 + ~(w1, g2) = uniform g1 + + ~(s, g3) = sample (0, maxBound) 16 g2 + + in ((if c1 then No.White else No.Black, w1, s), g3) + +tipsB :: [(No.Color, Word, Sample)] +tipsB = fst $ list tipB 1000 (mkStdGen 0) + +mkTipBin :: FromList set -> No.Color -> Word -> Sample -> [Case (set, NoSet) set NoSet] +mkTipBin setFromList c1 w1 (Sample c2 xs ys) = + let set1 = foldrFromList setFromList c1 [(w1, No.other c1)] + no1 = foldrFromList noFromList c1 [(w1, No.other c1)] + + set2 = foldrFromList setFromList c2 xs + no2 = foldrFromList noFromList c2 xs + + (setA, noA, setB, noB) | (_, No.Black):_ <- ys = (set2, no2, set1, no1) + | otherwise = (set1, no1, set2, no2) + + in [Case (setB, noB) setA noA]