tries 0.0.2 → 0.0.3
raw patch · 12 files changed
+494/−141 lines, 12 filesdep +deepseqdep +hashabledep +unordered-containersdep ~basedep ~composition-extradep ~rose-treessetup-changed
Dependencies added: deepseq, hashable, unordered-containers
Dependency ranges changed: base, composition-extra, rose-trees, sets
Files
- Setup.hs +2/−0
- bench/Bench.hs +39/−62
- bench/BenchLookup.hs +22/−0
- bench/Build.hs +82/−0
- src/Data/Trie/Class.hs +8/−1
- src/Data/Trie/HashMap.hs +178/−0
- src/Data/Trie/Knuth.hs +16/−6
- src/Data/Trie/List.hs +12/−3
- src/Data/Trie/Map.hs +18/−13
- src/Data/Trie/Pseudo.hs +28/−34
- test/Data/TrieSpec.hs +11/−0
- tries.cabal +78/−22
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
bench/Bench.hs view
@@ -1,78 +1,55 @@+{-# LANGUAGE+ FlexibleContexts+ #-}+ module Main where +import Build+ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import Data.Tree (Tree (..))-import Data.Trie.List as L-import Data.Trie.Map as M-import Data.Tree.Knuth.Forest as K-import Data.Trie.Knuth as K-import Data.Trie.Class as TC-import qualified Data.Map as Map+import Data.Trie.List as L+import Data.Trie.Map as M+import Data.Trie.HashMap as HM+import Data.Tree.Knuth.Forest as K+import Data.Trie.Knuth as K+import Data.Trie.Class as TC+import qualified Data.Map as Map+import qualified Data.HashMap.Lazy as HMap import Criterion.Main import Control.Monad.State -genListTrie :: Int -> ListTrie Int Int-genListTrie n = ListTrie $ Node (0, Just 0) $ genTree n- where- genTree :: Int -> [Tree (Int, Maybe Int)]- genTree n = evalState (replicateM n $ do- i <- getSucc- return $ Node (i, Just i) $ genTree (n-1)) 1 --getSucc :: State Int Int-getSucc = get <* modify (+1)---genMapTrie :: Int -> MapTrie Int Int-genMapTrie n = MapTrie $ MapStep $ Map.singleton 0- (Just 0, Just $ MapTrie $ MapStep $ genMapTree n)- where- genMapTree :: Int -> Map.Map Int (Maybe Int, Maybe (MapTrie Int Int))- genMapTree n = Map.unions $ evalState (replicateM n $ do- i <- getSucc- return $ Map.singleton i ( Just i- , if n <= 1 then Nothing- else Just $ MapTrie $ MapStep $ genMapTree (n-1))) 1-+deleteMany :: ( Trie NonEmpty Int c+ ) => Int -> c Int a -> c Int a+deleteMany top xs =+ foldr+ (\p -> TC.delete $ buildMiddleQuery top)+ xs+ [1..top] -genKnuthTrie :: Int -> KnuthTrie Int Int-genKnuthTrie n = KnuthTrie $ Fork (0, Just 0) (genKnuthForest n n) Nil- where- genKnuthForest :: Int -> Int -> KnuthForest (Int, Maybe Int)- genKnuthForest 0 _ = Nil- genKnuthForest n s = let cs = if n <= 1 then Nil else genKnuthForest (n-1) (n-1)- ss = if s <= 1 then Nil else genKnuthForest n (s-1)- in Fork (s, Just s) cs ss+insertMany :: ( Trie NonEmpty Int c+ ) => Int -> c Int Int -> c Int Int+insertMany top xs =+ foldr+ (\p -> TC.insert (buildMiddleQuery top) 0)+ xs+ [1..top] main = defaultMain- [ bgroup "lookup"- [ bgroup "ListTrie"- [ bench "1" $ whnf (TC.lookup $ 0 :| [100]) (genListTrie 100)- , bench "2" $ whnf (TC.lookup $ 0 :| [100,99..81]) (genListTrie 100)- , bench "3" $ whnf (TC.lookup $ 0 :| [100,99..61]) (genListTrie 100)- , bench "4" $ whnf (TC.lookup $ 0 :| [100,99..41]) (genListTrie 100)- , bench "5" $ whnf (TC.lookup $ 0 :| [100,99..21]) (genListTrie 100)- , bench "6" $ whnf (TC.lookup $ 0 :| [100,99..1]) (genListTrie 100)- ]- , bgroup "MapTrie"- [ bench "1" $ whnf (TC.lookup $ 0 :| [100]) (genMapTrie 100)- , bench "2" $ whnf (TC.lookup $ 0 :| [100,99..81]) (genMapTrie 100)- , bench "3" $ whnf (TC.lookup $ 0 :| [100,99..61]) (genMapTrie 100)- , bench "4" $ whnf (TC.lookup $ 0 :| [100,99..41]) (genMapTrie 100)- , bench "5" $ whnf (TC.lookup $ 0 :| [100,99..21]) (genMapTrie 100)- , bench "6" $ whnf (TC.lookup $ 0 :| [100,99..1]) (genMapTrie 100)- ]- , bgroup "KnuthTrie"- [ bench "1" $ whnf (TC.lookup $ 0 :| [100]) (genKnuthTrie 100)- , bench "2" $ whnf (TC.lookup $ 0 :| [100,99..81]) (genKnuthTrie 100)- , bench "3" $ whnf (TC.lookup $ 0 :| [100,99..61]) (genKnuthTrie 100)- , bench "4" $ whnf (TC.lookup $ 0 :| [100,99..41]) (genKnuthTrie 100)- , bench "5" $ whnf (TC.lookup $ 0 :| [100,99..21]) (genKnuthTrie 100)- , bench "6" $ whnf (TC.lookup $ 0 :| [100,99..1]) (genKnuthTrie 100)- ]+ [ bgroup "delete"+ [ bench "ListTrie" $ whnf (deleteMany 100) (genListTrie 100)+ , bench "MapTrie" $ whnf (deleteMany 100) (genMapTrie 100)+ , bench "HashMapTrie" $ whnf (deleteMany 100) (genHashMapTrie 100)+ , bench "KnuthTrie" $ whnf (deleteMany 100) (genKnuthTrie 100)+ ]+ , bgroup "insert"+ [ bench "ListTrie" $ whnf (insertMany 100) (genListTrie 100)+ , bench "MapTrie1" $ whnf (insertMany 100) (genMapTrie 100)+ , bench "HashMapTrie" $ whnf (insertMany 100) (genHashMapTrie 100)+ , bench "KnuthTrie" $ whnf (insertMany 100) (genKnuthTrie 100) ] ]
+ bench/BenchLookup.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE+ FlexibleContexts+ #-}++module Main where++import Build++import Data.Trie.Class as TC+import Criterion.Main+++main = defaultMain+ [ bgroup "lookup"+ [ bgroup "ListTrie" $ benchOne genListTrie <$> [10,20..100]+ , bgroup "MapTrie" $ benchOne genMapTrie <$> [10,20..100]+ , bgroup "HashMapTrie" $ benchOne genHashMapTrie <$> [10,20..100]+ , bgroup "KnuthTrie" $ benchOne genKnuthTrie <$> [10,20..100]+ ]+ ]+ where+ benchOne gen x = bench (show x) $ whnf (TC.lookup $ buildMiddleQuery x) (gen 100)
+ bench/Build.hs view
@@ -0,0 +1,82 @@+module Build where++++import Data.List.NonEmpty (NonEmpty (..))+import Data.Tree (Tree (..))+import Data.Trie.List as L+import Data.Trie.Map as M+import Data.Trie.HashMap as HM+import Data.Tree.Knuth.Forest as K+import Data.Trie.Knuth as K+import qualified Data.Map as Map+import qualified Data.HashMap.Lazy as HMap+import Control.Monad.State+++buildMiddleQuery :: Int -> NonEmpty Int+buildMiddleQuery x = 0 :| go x+ where+ go n =+ let half = floor ((fromIntegral n)/2)+ in if half == 0+ then []+ else half : go (floor $ (fromIntegral n)/2)+++genListTrie :: Int -> ListTrie Int Int+genListTrie n = ListTrie $ Node (0, Just 0) $ genTree n+ where+ genTree :: Int -> [Tree (Int, Maybe Int)]+ genTree n = flip evalState 1 $ replicateM n $ do+ i <- getSucc+ return $ Node (i, Just 0) $ genTree (floor $ (fromIntegral n)/2)+++getSucc :: State Int Int+getSucc = do+ i <- get+ modify (+1)+ pure i+++genMapTrie :: Int -> MapTrie Int Int+genMapTrie n = MapTrie $ MapStep $ Map.singleton 0+ (Just 0, Just $ MapTrie $ MapStep $ genMapTree n)+ where+ genMapTree :: Int -> Map.Map Int (Maybe Int, Maybe (MapTrie Int Int))+ genMapTree n =+ Map.unions . flip evalState 1 $+ replicateM n $ do+ i <- getSucc+ pure $ Map.singleton i ( Just 0+ , if n <= 1+ then Nothing+ else Just . MapTrie . MapStep $ genMapTree (floor $ (fromIntegral n)/2)+ )++genHashMapTrie :: Int -> HashMapTrie Int Int+genHashMapTrie n =+ HashMapTrie $ HashMapStep $ HMap.singleton 0+ (Just 0, Just . HashMapTrie . HashMapStep $ genHashMapTree n)+ where+ genHashMapTree :: Int -> HMap.HashMap Int (Maybe Int, Maybe (HashMapTrie Int Int))+ genHashMapTree n = HMap.unions $ flip evalState 1 $+ replicateM n $ do+ i <- getSucc+ return $ HMap.singleton i ( Just 0+ , if n <= 1+ then Nothing+ else Just . HashMapTrie . HashMapStep $ genHashMapTree (floor $ (fromIntegral n)/2)+ )+++-- | This one is ordered largest first+genKnuthTrie :: Int -> KnuthTrie Int Int+genKnuthTrie n = KnuthTrie $ Fork (0, Just 0) (genKnuthForest n n) Nil+ where+ genKnuthForest :: Int -> Int -> KnuthForest (Int, Maybe Int)+ genKnuthForest 0 _ = Nil+ genKnuthForest n s = let cs = if n == 0 then Nil else genKnuthForest (floor $ (fromIntegral n)/2) (n-1)+ ss = if s == 0 then Nil else genKnuthForest n (s-1)+ in Fork (s, Just 0) cs ss
src/Data/Trie/Class.hs view
@@ -11,9 +11,9 @@ import Data.Function.Syntax import Data.Maybe (isJust, fromMaybe)-import Data.Monoid import Data.Foldable as F import Data.Functor.Identity (Identity (..))+-- import Data.Map.TernaryMap as TM -- | Class representing tries with single-threaded insertion, deletion, and lookup.@@ -40,6 +40,13 @@ fromFoldable :: (Foldable f, Monoid (t s a), Trie p s t) => f (p s, a) -> t s a fromFoldable = F.foldr (uncurry insert) mempty ++-- * Ternary Map++-- TODO+-- instance Ord k => Trie [] k TernaryMap where+-- lookup = TM.lookup+-- delete = TM.delete -- * ByteString-Trie
+ src/Data/Trie/HashMap.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE+ GeneralizedNewtypeDeriving+ , DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , DeriveGeneric+ , DeriveDataTypeable+ , MultiParamTypeClasses+ , FlexibleInstances+ , FlexibleContexts+ , TypeFamilies+ , TupleSections+ #-}++module Data.Trie.HashMap where++import Data.Trie.Class+import Data.Monoid+import Data.Hashable+import Data.Maybe (fromMaybe, fromJust)+import qualified Data.Foldable as F+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.HashMap.Lazy as HM+import qualified Data.Key as K+import Control.Monad++import Data.Data+import GHC.Generics+import Control.DeepSeq+import Prelude hiding (lookup, null)+import Test.QuickCheck+import Test.QuickCheck.Instances ()+++-- * One Step++newtype HashMapStep c p a = HashMapStep+ { unHashMapStep :: HM.HashMap p (Maybe a, Maybe (c p a))+ } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data, Typeable)++instance ( NFData (c p a)+ , NFData p+ , NFData a+ ) => NFData (HashMapStep c p a)++instance ( Arbitrary a+ , Arbitrary p+ , Arbitrary (c p a)+ , Hashable p+ , Eq p+ ) => Arbitrary (HashMapStep c p a) where+ arbitrary = sized go+ where+ go n = do+ i <- choose (0,n)+ xs <- replicateM i $ (,) <$> arbitrary <*> resize (floor (fromIntegral n / 2 :: Float)) arbitrary+ return $ HashMapStep $ HM.fromList xs++instance ( Hashable p+ , Eq p+ , Trie NonEmpty p c+ ) => Trie NonEmpty p (HashMapStep c) where+ lookup (p:|ps) (HashMapStep xs)+ | F.null ps = fst =<< HM.lookup p xs+ | otherwise = lookup (NE.fromList ps) =<< snd =<< HM.lookup p xs+ delete (p:|ps) (HashMapStep xs)+ | F.null ps = let mxs = snd =<< HM.lookup p xs+ in HashMapStep $ HM.insert p (Nothing,mxs) xs+ | otherwise = let (mx,mxs) = fromMaybe (Nothing,Nothing) $ HM.lookup p xs+ in HashMapStep $ HM.insert p (mx, delete (NE.fromList ps) <$> mxs) xs++insert :: ( Hashable p+ , Eq p+ , Trie NonEmpty p c+ , Monoid (c p a)+ ) => NonEmpty p -> a -> HashMapStep c p a -> HashMapStep c p a+insert (p:|ps) x (HashMapStep xs)+ | F.null ps = let mxs = snd =<< HM.lookup p xs+ in HashMapStep $ HM.insert p (Just x,mxs) xs+ | otherwise = let mx = fst =<< HM.lookup p xs+ xs' = fromMaybe mempty (snd =<< HM.lookup p xs)+ in HashMapStep $ HM.insert p (mx, Just $ Data.Trie.Class.insert (NE.fromList ps) x xs') xs+++instance ( Hashable p+ , Eq p+ , Monoid (c p a)+ ) => Monoid (HashMapStep c p a) where+ mempty = empty+ mappend (HashMapStep xs) (HashMapStep ys) = HashMapStep $ HM.unionWith go xs ys+ where go (mx,mxs) (my,mys) = (getLast $ Last mx <> Last my, mxs <> mys)++empty :: HashMapStep c p a+empty = HashMapStep HM.empty++singleton :: Hashable p => p -> a -> HashMapStep c p a+singleton p x = HashMapStep $ HM.singleton p (Just x, Nothing)++-- * Fixpoint of Steps+++newtype HashMapTrie p a = HashMapTrie+ { unHashMapTrie :: HashMapStep HashMapTrie p a+ } deriving (Show, Eq, Functor, Foldable, Traversable, Monoid, Arbitrary)+++instance ( Hashable p+ , Eq p+ ) => Trie NonEmpty p HashMapTrie where+ lookup ts (HashMapTrie xs) = lookup ts xs+ delete ts (HashMapTrie xs) = HashMapTrie $ delete ts xs+ insert ts x (HashMapTrie xs) = HashMapTrie $ Data.Trie.HashMap.insert ts x xs++type instance K.Key (HashMapTrie p) = NonEmpty p++instance ( Hashable p+ , Eq p+ ) => K.Lookup (HashMapTrie p) where+ lookup = lookup++-- * Conversion++keys :: ( Hashable p+ , Eq p+ ) => HashMapTrie p a -> [NonEmpty p]+keys (HashMapTrie (HashMapStep xs)) =+ let ks = HM.keys xs+ in F.concatMap go ks+ where+ go k = let (_,mxs) = fromJust $ HM.lookup k xs+ in fmap (k :|) $ fromMaybe [] $ do xs' <- mxs+ return $ NE.toList <$> keys xs'+++elems :: HashMapTrie p a -> [a]+elems = F.toList++-- * Query+++subtrie :: ( Hashable p+ , Eq p+ ) => NonEmpty p -> HashMapTrie p a -> Maybe (HashMapTrie p a)+subtrie (p:|ps) (HashMapTrie (HashMapStep xs))+ | F.null ps = snd =<< HM.lookup p xs+ | otherwise = subtrie (NE.fromList ps) =<< snd =<< HM.lookup p xs+++-- lookupNearest ~ match+match :: ( Hashable p+ , Eq p+ ) => NonEmpty p -> HashMapTrie p a -> Maybe (NonEmpty p, a, [p])+match (p:|ps) (HashMapTrie (HashMapStep xs)) = do+ (mx,mxs) <- HM.lookup p xs+ let mFoundHere = (p:|[],, ps) <$> mx+ if F.null ps+ then mFoundHere+ else getFirst $ First (do (pre,y,suff) <- match (NE.fromList ps) =<< mxs+ pure (p:|NE.toList pre, y, suff))+ <> First mFoundHere++-- | Returns a list of all the nodes along the path to the furthest point in the+-- query, in order of the path walked from the root to the furthest point.+matches :: ( Hashable p+ , Eq p+ ) => NonEmpty p -> HashMapTrie p a -> [(NonEmpty p, a, [p])]+matches (p:|ps) (HashMapTrie (HashMapStep xs)) =+ let (mx,mxs) = fromMaybe (Nothing,Nothing) $ HM.lookup p xs+ foundHere = fromMaybe [] $ (\x -> [(p:|[],x,ps)]) <$> mx+ in if F.null ps+ then foundHere+ else let rs = fromMaybe [] $ matches (NE.fromList ps) <$> mxs+ in foundHere ++ (prependAncestry <$> rs)+ where prependAncestry (pre,x,suff) = (p:| NE.toList pre,x,suff)+++
src/Data/Trie/Knuth.hs view
@@ -2,6 +2,8 @@ DeriveFunctor , DeriveFoldable , DeriveTraversable+ , DeriveGeneric+ , DeriveDataTypeable , GeneralizedNewtypeDeriving , FlexibleInstances , MultiParamTypeClasses@@ -16,29 +18,37 @@ import Data.Trie.Class +import Data.Data+import GHC.Generics+import Control.DeepSeq import Test.QuickCheck newtype KnuthTrie s x = KnuthTrie- {unKnuthTrie :: KnuthForest (s, Maybe x)}- deriving (Show, Eq, Functor, Foldable, Traversable, Arbitrary)+ { unKnuthTrie :: KnuthForest (s, Maybe x)+ } deriving (Show, Eq, Functor, Foldable, Traversable, Arbitrary, Generic, Data, Typeable) +instance ( NFData s+ , NFData x+ ) => NFData (KnuthTrie s x)+ instance Eq s => Trie NonEmpty s KnuthTrie where lookup _ (KnuthTrie Nil) = Nothing lookup tss@(t:|ts) (KnuthTrie (Fork (t',mx) cs ss))- | t == t' = if null ts then mx+ | t == t' = if null ts+ then mx else lookup (NE.fromList ts) $ KnuthTrie cs | otherwise = lookup tss $ KnuthTrie ss insert (t:|ts) x (KnuthTrie Nil) | null ts = KnuthTrie $ Fork (t,Just x) Nil Nil | otherwise = let cs' = unKnuthTrie $ insert (NE.fromList ts) x $ KnuthTrie Nil- in KnuthTrie $ Fork (t,Nothing) cs' Nil+ in KnuthTrie $ Fork (t,Nothing) cs' Nil insert tss@(t:|ts) x (KnuthTrie (Fork s@(t',_) cs ss)) | t == t' = if null ts then KnuthTrie $ Fork (t',Just x) cs ss else let cs' = unKnuthTrie $ insert (NE.fromList ts) x $ KnuthTrie cs- in KnuthTrie $ Fork s cs' ss+ in KnuthTrie $ Fork s cs' ss | otherwise = KnuthTrie $ Fork s cs $ unKnuthTrie $ insert tss x $ KnuthTrie ss delete _ xs@(KnuthTrie Nil) = xs@@ -46,5 +56,5 @@ | t == t' = if null ts then KnuthTrie $ Fork (t',Nothing) cs ss else let cs' = unKnuthTrie $ delete (NE.fromList ts) $ KnuthTrie cs- in KnuthTrie $ Fork s cs' ss+ in KnuthTrie $ Fork s cs' ss | otherwise = KnuthTrie $ Fork s cs $ unKnuthTrie $ delete tss $ KnuthTrie ss
src/Data/Trie/List.hs view
@@ -2,6 +2,8 @@ TypeFamilies , DeriveFunctor , DeriveFoldable+ , DeriveGeneric+ , DeriveDataTypeable , DeriveTraversable , GeneralizedNewtypeDeriving , FlexibleInstances@@ -22,14 +24,21 @@ import Data.Monoid import Control.Monad +import Data.Data+import GHC.Generics+import Control.DeepSeq import Test.QuickCheck-import Test.QuickCheck.Instances+import Test.QuickCheck.Instances () newtype ListTrie t x = ListTrie { unListTrie :: Tree (t, Maybe x)- } deriving (Show, Eq, Functor, Foldable, Traversable, Arbitrary)+ } deriving (Show, Eq, Functor, Foldable, Traversable, Arbitrary, Generic, Data, Typeable) +instance ( NFData t+ , NFData x+ ) => NFData (ListTrie t x)+ type instance Key (ListTrie s) = NonEmpty s -- TODO: Trie instance @@ -60,4 +69,4 @@ then fmap (unListTrie . insert (NE.fromList ts) x . ListTrie) xs else xs ++ [unListTrie $ insert (NE.fromList ts) x $ ListTrie $ Node (head ts, Nothing) []]- hasHead t (Node (t',_) _) = t == t'+ hasHead tag (Node (tag',_) _) = tag == tag'
src/Data/Trie/Map.hs view
@@ -2,6 +2,8 @@ DeriveFunctor , DeriveFoldable , DeriveTraversable+ , DeriveGeneric+ , DeriveDataTypeable , GeneralizedNewtypeDeriving , TupleSections , TypeFamilies@@ -19,24 +21,31 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import qualified Data.Set.Class as S import qualified Data.Key as K import qualified Data.Foldable as F import Data.Maybe import Data.Monoid import Control.Monad +import Data.Data+import GHC.Generics+import Control.DeepSeq import Test.QuickCheck-import Test.QuickCheck.Instances+import Test.QuickCheck.Instances () -- * One Step newtype MapStep c p a = MapStep- { unMapStep :: Map.Map p (Maybe a, Maybe (c p a)) }- deriving (Show, Eq, Ord, Functor, Foldable, Traversable)+ { unMapStep :: Map.Map p (Maybe a, Maybe (c p a))+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Data, Typeable) +instance ( NFData (c p a)+ , NFData p+ , NFData a+ ) => NFData (MapStep c p a)+ instance (Arbitrary a, Arbitrary p, Arbitrary (c p a), Ord p) => Arbitrary (MapStep c p a) where arbitrary = sized go where@@ -50,10 +59,8 @@ -- instead. instance (Ord p, Trie NonEmpty p c) => Trie NonEmpty p (MapStep c) where lookup (p:|ps) (MapStep xs)- | F.null ps = do (mx,_) <- Map.lookup p xs- mx- | otherwise = do (_,mxs) <- Map.lookup p xs- lookup (NE.fromList ps) =<< mxs+ | F.null ps = fst =<< Map.lookup p xs+ | otherwise = lookup (NE.fromList ps) =<< snd =<< Map.lookup p xs delete (p:|ps) (MapStep xs) | F.null ps = let mxs = snd =<< Map.lookup p xs in MapStep $ Map.insert p (Nothing,mxs) xs@@ -68,7 +75,7 @@ insert (p:|ps) x (MapStep xs) | F.null ps = let mxs = snd =<< Map.lookup p xs in MapStep $ Map.insert p (Just x,mxs) xs- | otherwise = let mx = fst =<< Map.lookup p xs+ | otherwise = let mx = fst =<< Map.lookup p xs xs' = fromMaybe mempty (snd =<< Map.lookup p xs) in MapStep $ Map.insert p (mx, Just $ Data.Trie.Class.insert (NE.fromList ps) x xs') xs @@ -120,10 +127,8 @@ subtrie :: Ord s => NonEmpty s -> MapTrie s a -> Maybe (MapTrie s a) subtrie (p:|ps) (MapTrie (MapStep xs))- | F.null ps = do (_,mxs) <- Map.lookup p xs- mxs- | otherwise = do (_,mxs) <- Map.lookup p xs- subtrie (NE.fromList ps) =<< mxs+ | F.null ps = snd =<< Map.lookup p xs+ | otherwise = subtrie (NE.fromList ps) =<< snd =<< Map.lookup p xs -- lookupNearest ~ match match :: Ord s => NonEmpty s -> MapTrie s a -> Maybe (NonEmpty s, a, [s])
src/Data/Trie/Pseudo.hs view
@@ -10,15 +10,9 @@ import Prelude hiding (foldl, foldr, foldr1, lookup, map) import Data.Foldable hiding (all)-import Data.List (intercalate)-import Data.List.NonEmpty (NonEmpty (..), fromList, toList)+import Data.List.NonEmpty (NonEmpty (..), fromList) import qualified Data.List.NonEmpty as NE-import Data.Maybe (fromMaybe)-import Data.Monoid-import qualified Data.Semigroup as S -import Control.Applicative-import Control.Monad (replicateM) import Control.Arrow (second) @@ -49,16 +43,16 @@ (Just x) -> Rest pss x Nothing -> Nil | t == p = case (ts,ps) of- ([], p':_) -> More t mx $ Rest (NE.fromList ps) y :| []- (t':_, []) -> case mx of- Just x -> More p (Just y) $ Rest (NE.fromList ts) x :| []- Nothing -> ys+ ([],_) -> More t mx $ Rest (NE.fromList ps) y :| []+ (_,[]) -> case mx of+ Just x -> More p (Just y) $ Rest (NE.fromList ts) x :| []+ Nothing -> ys (t':_,p':_) -> if t' == p' then More t Nothing $ assign (NE.fromList ts) mx (Rest (NE.fromList ps) y) :| [] else case mx of -- disjoint Nothing -> ys- Just x -> More t Nothing $ NE.fromList $+ Just x -> More t Nothing $ NE.fromList [ Rest (NE.fromList ps) y , Rest (NE.fromList ts) x ]@@ -76,13 +70,13 @@ merge xx@(Rest tss@(t:|ts) x) (Rest pss@(p:|ps) y) | tss == pss = Rest pss y | t == p = case (ts,ps) of- ([],p':ps') -> More t (Just x) $ Rest (NE.fromList ps) y :| []- (t':ts',[]) -> More t (Just y) $ Rest (NE.fromList ts) x :| []- (_,_) -> More t Nothing $- merge (Rest (NE.fromList ts) x)- (Rest (NE.fromList ps) y) :| []+ ([],_) -> More t (Just x) $ Rest (NE.fromList ps) y :| []+ (_,[]) -> More t (Just y) $ Rest (NE.fromList ts) x :| []+ (_,_) -> More t Nothing $+ merge (Rest (NE.fromList ts) x)+ (Rest (NE.fromList ps) y) :| [] | otherwise = xx-merge xx@(More t mx xs) (More p my ys)+merge xx@(More t _ xs) (More p my ys) | t == p = More p my $ NE.fromList $ foldr go [] $ NE.toList xs ++ NE.toList ys | otherwise = xx@@ -90,13 +84,13 @@ go q [] = [q] go q (z:zs) | areDisjoint q z = q : z : zs | otherwise = merge q z : zs-merge xx@(More t mx xs) (Rest pss@(p:|ps) y)+merge xx@(More t mx xs) (Rest (p:|ps) y) | t == p = case ps of [] -> More t (Just y) xs _ -> More t mx $ fmap (flip merge $ Rest (NE.fromList ps) y) xs | otherwise = xx-merge xx@(Rest tss@(t:|ts) x) (More p my ys)+merge xx@(Rest (t:|ts) x) (More p my ys) | t == p = case ts of [] -> More p (Just x) ys _ -> More p my $@@ -111,15 +105,15 @@ where mkMores :: (Eq t) => [t] -> PseudoTrie t a -> PseudoTrie t a mkMores [] trie = trie- mkMores (t:ts) trie = More t Nothing $- mkMores ts trie :| []+ mkMores (p:ps) trie = More p Nothing $+ mkMores ps trie :| [] toAssocs :: PseudoTrie t a -> [(NonEmpty t, a)] toAssocs = go [] [] where go :: [t] -> [(NonEmpty t, a)] -> PseudoTrie t a -> [(NonEmpty t, a)]- go depth acc Nil = acc+ go _ acc Nil = acc go depth acc (Rest ts x) = (NE.fromList $ depth ++ NE.toList ts, x) : acc go depth acc (More t Nothing xs) = foldr (flip $ go $ depth ++ [t]) acc $ NE.toList xs@@ -135,17 +129,17 @@ lookup tss (Rest pss a) | tss == pss = Just a | otherwise = Nothing-lookup tss@(t:|ts) (More p mx xs)+lookup (t:|ts) (More p mx xs) | t == p = case ts of [] -> mx- (t':ts') -> find (hasNextTag t') xs >>= lookup (fromList ts)+ (t':_) -> find (hasNextTag t') xs >>= lookup (fromList ts) | otherwise = Nothing where hasNextTag :: (Eq t) => t -> PseudoTrie t a -> Bool- hasNextTag t Nil = False- hasNextTag t (More p _ _) = t == p- hasNextTag t (Rest (p:|_) _) = t == p+ hasNextTag _ Nil = False+ hasNextTag tag (More tag' _ _) = tag == tag'+ hasNextTag tag (Rest (tag':|_) _) = tag == tag' -- | Simple test on the heads of two tries areDisjoint :: (Eq t) => PseudoTrie t a -> PseudoTrie t a -> Bool@@ -165,7 +159,7 @@ -> PseudoTrie t c intersectionWith _ _ Nil = Nil intersectionWith _ Nil _ = Nil-intersectionWith f (Rest tss@(t:|ts) x) (Rest pss@(p:|ps) y)+intersectionWith f (Rest tss x) (Rest pss y) | tss == pss = Rest pss $ f x y | otherwise = Nil intersectionWith f (More t mx xs) (More p my ys)@@ -176,14 +170,14 @@ zs -> More p (f <$> mx <*> my) $ NE.fromList zs -- implicit root | otherwise = Nil-intersectionWith f (More t mx xs) (Rest pss@(p:|ps) y)+intersectionWith f (More t mx xs) (Rest (p:|ps) y) | t == p = case ps of [] -> case f <$> mx <*> Just y of Nothing -> Nil Just c -> Rest (p :| []) c _ -> More p Nothing $ fmap (flip (intersectionWith f) $ Rest (fromList ps) y) xs | otherwise = Nil-intersectionWith f (Rest tss@(t:|ts) x) (More p my ys)+intersectionWith f (Rest (t:|ts) x) (More p my ys) | t == p = case ts of [] -> case f <$> Just x <*> my of Nothing -> Nil@@ -203,7 +197,7 @@ prune = go where go Nil = Nil- go xx@(Rest ts x) = xx+ go xx@(Rest _ _) = xx go (More t Nothing xs) = case cleaned xs of [Nil] -> Nil@@ -221,5 +215,5 @@ ys -> ys where removeNils' [] = []- removeNils' (Nil:xs) = removeNils' xs- removeNils' (x:xs) = x : removeNils' xs+ removeNils' (Nil:xs') = removeNils' xs'+ removeNils' (x:xs') = x : removeNils' xs'
test/Data/TrieSpec.hs view
@@ -11,6 +11,7 @@ import Data.Trie.List as L import Data.Tree (Tree (..)) import Data.Trie.Map as M hiding (insert)+import Data.Trie.HashMap as HM hiding (insert) import Data.Trie.Knuth as K hiding (lookup, insert, delete) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE@@ -32,6 +33,10 @@ [ QC.testProperty "lookup after insertion should exist" lookupInsertExists_Map , QC.testProperty "lookup after deletion should not exist" lookupDeleteNotExists_Map ]+ , testGroup "Data.Trie.HashMap"+ [ QC.testProperty "lookup after insertion should exist" lookupInsertExists_HashMap+ , QC.testProperty "lookup after deletion should not exist" lookupDeleteNotExists_HashMap+ ] , testGroup "Data.Trie.Knuth" [ QC.testProperty "lookup after insertion should exist" lookupInsertExists_Knuth , QC.testProperty "lookup after deletion should not exist" lookupDeleteNotExists_Knuth@@ -57,6 +62,9 @@ lookupInsertExists_Map :: NonEmpty Int -> Int -> MapTrie Int Int -> Bool lookupInsertExists_Map = lookupInsertExists +lookupInsertExists_HashMap :: NonEmpty Int -> Int -> HashMapTrie Int Int -> Bool+lookupInsertExists_HashMap = lookupInsertExists+ lookupInsertExists_Knuth :: NonEmpty Int -> Int -> KnuthTrie Int Int -> Bool lookupInsertExists_Knuth = lookupInsertExists @@ -74,6 +82,9 @@ lookupDeleteNotExists_Map :: NonEmpty Int -> MapTrie Int Int -> Bool lookupDeleteNotExists_Map = lookupDeleteNotExists++lookupDeleteNotExists_HashMap :: NonEmpty Int -> HashMapTrie Int Int -> Bool+lookupDeleteNotExists_HashMap = lookupDeleteNotExists lookupDeleteNotExists_Knuth :: NonEmpty Int -> KnuthTrie Int Int -> Bool lookupDeleteNotExists_Knuth = lookupDeleteNotExists
tries.cabal view
@@ -1,5 +1,5 @@ Name: tries-Version: 0.0.2+Version: 0.0.3 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -10,59 +10,71 @@ Build-Type: Simple Category: Data, Tree +flag Lookup+ Description: Benchmark the lookup functions+ Default: False+ Library Default-Language: Haskell2010 HS-Source-Dirs: src GHC-Options: -Wall Exposed-Modules: Data.Trie.Class+ Data.Trie.HashMap Data.Trie.Knuth Data.Trie.List Data.Trie.Map Data.Trie.Pseudo- Build-Depends: base >= 4.6 && < 5- , containers+ Build-Depends: base >= 4.8 && < 5 , bytestring , bytestring-trie- , semigroups- , rose-trees >= 0.0.2 , composition , composition-extra >= 2.0.0+ , containers+ , deepseq+ , hashable , keys+-- , TernaryTrees+ , rose-trees >= 0.0.2.1+ , semigroups , sets >= 0.0.5+ , unordered-containers , QuickCheck , quickcheck-instances- , mtl- , criterion Test-Suite test Type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: src , test- Ghc-Options: -Wall+ Ghc-Options: -Wall -threaded Main-Is: Spec.hs Other-Modules: Data.TrieSpec Data.Trie.Class+ Data.Trie.HashMap Data.Trie.Knuth Data.Trie.List Data.Trie.Map Data.Trie.Pseudo Build-Depends: base- , tries- , tasty- , tasty-quickcheck- , QuickCheck- , quickcheck-instances- , containers , bytestring , bytestring-trie- , semigroups- , rose-trees , composition , composition-extra+ , deepseq+-- , TernaryTrees+ , containers+ , hashable , keys- , sets , mtl+ , rose-trees+ , sets+ , semigroups+ , tries+ , tasty+ , tasty-quickcheck+ , unordered-containers+ , QuickCheck+ , quickcheck-instances Benchmark bench@@ -70,28 +82,72 @@ Default-Language: Haskell2010 Hs-Source-Dirs: src , bench- Ghc-Options: -Wall+ Ghc-Options: -Wall -threaded Main-Is: Bench.hs Other-Modules: Data.Trie.Class+ Data.Trie.HashMap Data.Trie.Knuth Data.Trie.List Data.Trie.Map Data.Trie.Pseudo+ Build Build-Depends: base+ , bytestring+ , bytestring-trie+ , composition+ , composition-extra+ , containers+ , deepseq+-- , TernaryTrees+ , hashable+ , keys+ , mtl+ , rose-trees+ , semigroups+ , sets , tries+ , unordered-containers+ , QuickCheck+ , quickcheck-instances , criterion- , containers++Benchmark bench-lookup+ if flag(Lookup)+ Buildable: True+ else+ Buildable: False+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: src+ , bench+ Ghc-Options: -Wall -threaded+ Main-Is: BenchLookup.hs+ Other-Modules: Data.Trie.Class+ Data.Trie.HashMap+ Data.Trie.Knuth+ Data.Trie.List+ Data.Trie.Map+ Data.Trie.Pseudo+ Build+ Build-Depends: base , bytestring , bytestring-trie- , semigroups- , rose-trees , composition , composition-extra+ , containers+ , deepseq+-- , TernaryTrees+ , hashable , keys- , sets , mtl+ , rose-trees+ , semigroups+ , sets+ , tries+ , unordered-containers , QuickCheck , quickcheck-instances+ , criterion Source-Repository head Type: git