tries 0.0.3 → 0.0.4
raw patch · 4 files changed
+165/−79 lines, 4 files
Files
- bench/Build.hs +18/−17
- src/Data/Trie/HashMap.hs +72/−26
- src/Data/Trie/Map.hs +74/−35
- tries.cabal +1/−1
bench/Build.hs view
@@ -41,34 +41,35 @@ genMapTrie :: Int -> MapTrie Int Int-genMapTrie n = MapTrie $ MapStep $ Map.singleton 0- (Just 0, Just $ MapTrie $ MapStep $ genMapTree n)+genMapTrie n = MapTrie . MapStep . Map.singleton 0 $+ MapChildren (Just 0) $ Just . MapTrie . MapStep $ genMapTree n where- genMapTree :: Int -> Map.Map Int (Maybe Int, Maybe (MapTrie Int Int))+ genMapTree :: Int -> Map.Map Int (MapChildren 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)- )+ pure $ Map.singleton i $+ MapChildren (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)+genHashMapTrie n = HashMapTrie $ HashMapStep $ HMap.singleton 0 $+ HashMapChildren (Just 0) $ Just . HashMapTrie . HashMapStep $ genHashMapTree n where- genHashMapTree :: Int -> HMap.HashMap Int (Maybe Int, Maybe (HashMapTrie Int Int))+ genHashMapTree :: Int -> HMap.HashMap Int (HashMapChildren 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)- )+ return $ HMap.singleton i $+ HashMapChildren (Just 0) $+ if n <= 1+ then Nothing+ else Just . HashMapTrie . HashMapStep $ genHashMapTree (floor $ fromIntegral n / 2)+ -- | This one is ordered largest first
src/Data/Trie/HashMap.hs view
@@ -8,6 +8,7 @@ , MultiParamTypeClasses , FlexibleInstances , FlexibleContexts+ , UndecidableInstances , TypeFamilies , TupleSections #-}@@ -35,8 +36,31 @@ -- * One Step +data HashMapChildren c p a = HashMapChildren+ { hashMapNode :: Maybe a+ , hashMapChildren :: !(Maybe (c p a))+ } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data, Typeable)++instance ( NFData (c p a)+ , NFData p+ , NFData a+ ) => NFData (HashMapChildren c p a)++instance ( Arbitrary a+ , Arbitrary p+ , Arbitrary (c p a)+ ) => Arbitrary (HashMapChildren c p a) where+ arbitrary = HashMapChildren <$> arbitrary <*> scale (\n -> floor $ fromIntegral n / 2) arbitrary++instance ( Monoid (c p a)+ ) => Monoid (HashMapChildren c p a) where+ mempty = HashMapChildren Nothing Nothing+ mappend (HashMapChildren mx mxs) (HashMapChildren my mys) =+ HashMapChildren (getLast $ Last mx <> Last my)+ (mxs <> mys)+ newtype HashMapStep c p a = HashMapStep- { unHashMapStep :: HM.HashMap p (Maybe a, Maybe (c p a))+ { unHashMapStep :: HM.HashMap p (HashMapChildren c p a) } deriving (Show, Eq, Functor, Foldable, Traversable, Generic, Data, Typeable) instance ( NFData (c p a)@@ -54,7 +78,7 @@ where go n = do i <- choose (0,n)- xs <- replicateM i $ (,) <$> arbitrary <*> resize (floor (fromIntegral n / 2 :: Float)) arbitrary+ xs <- replicateM i $ (,) <$> arbitrary <*> resize (floor $ fromIntegral n / 2) arbitrary return $ HashMapStep $ HM.fromList xs instance ( Hashable p@@ -62,13 +86,21 @@ , 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+ | F.null ps = hashMapNode+ =<< HM.lookup p xs+ | otherwise = lookup (NE.fromList ps)+ =<< hashMapChildren+ =<< 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+ | F.null ps = let mxs = hashMapChildren =<< HM.lookup p xs+ in HashMapStep $! HM.insert p (HashMapChildren Nothing $! mxs) xs+ | otherwise = let (HashMapChildren mx mxs) =+ fromMaybe (HashMapChildren Nothing Nothing)+ (HM.lookup p xs)+ in HashMapStep $! HM.insert p+ (HashMapChildren mx $!+ delete (NE.fromList ps) <$> mxs)+ xs insert :: ( Hashable p , Eq p@@ -76,27 +108,35 @@ , 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+ | F.null ps = let mxs = hashMapChildren =<< HM.lookup p xs+ in HashMapStep $! HM.insert p+ (HashMapChildren (Just x) $! mxs)+ xs+ | otherwise = let mx = hashMapNode =<< HM.lookup p xs+ xs' = fromMaybe mempty $! hashMapChildren =<< HM.lookup p xs+ in HashMapStep $! HM.insert p+ (HashMapChildren mx $+ Just $! Data.Trie.Class.insert (NE.fromList ps) x xs')+ xs +{-# INLINEABLE insert #-} 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)+ mappend (HashMapStep xs) (HashMapStep ys) =+ HashMapStep $ HM.unionWith (<>) xs ys 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)+singleton p x = HashMapStep $! HM.singleton p $ HashMapChildren (Just x) Nothing +{-# INLINEABLE singleton #-}+ -- * Fixpoint of Steps @@ -108,8 +148,8 @@ 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+ 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@@ -126,12 +166,14 @@ ) => HashMapTrie p a -> [NonEmpty p] keys (HashMapTrie (HashMapStep xs)) = let ks = HM.keys xs- in F.concatMap go ks+ 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'+ go k = let (HashMapChildren _ mxs) = fromJust $ HM.lookup k xs+ in map (k :|) $ fromMaybe [] $ do+ xs' <- mxs+ return $ NE.toList <$> keys xs' +{-# INLINEABLE keys #-} elems :: HashMapTrie p a -> [a] elems = F.toList@@ -143,16 +185,17 @@ , 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+ | F.null ps = hashMapChildren =<< HM.lookup p xs+ | otherwise = subtrie (NE.fromList ps) =<< hashMapChildren =<< HM.lookup p xs +{-# INLINEABLE subtrie #-} -- 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+ (HashMapChildren mx mxs) <- HM.lookup p xs let mFoundHere = (p:|[],, ps) <$> mx if F.null ps then mFoundHere@@ -160,13 +203,15 @@ pure (p:|NE.toList pre, y, suff)) <> First mFoundHere +{-# INLINEABLE match #-}+ -- | 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+ let (HashMapChildren mx mxs) = fromMaybe mempty $ HM.lookup p xs foundHere = fromMaybe [] $ (\x -> [(p:|[],x,ps)]) <$> mx in if F.null ps then foundHere@@ -174,5 +219,6 @@ in foundHere ++ (prependAncestry <$> rs) where prependAncestry (pre,x,suff) = (p:| NE.toList pre,x,suff) +{-# INLINEABLE matches #-}
src/Data/Trie/Map.hs view
@@ -17,12 +17,12 @@ import Data.Trie.Class import Prelude hiding (lookup, null)-import qualified Data.Map as Map+import qualified Data.Map as Map import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import qualified Data.Key as K-import qualified Data.Foldable as F+import qualified Data.Key as K+import qualified Data.Foldable as F import Data.Maybe import Data.Monoid import Control.Monad@@ -37,8 +37,32 @@ -- * One Step +data MapChildren c p a = MapChildren+ { mapNode :: Maybe a+ , mapChildren :: !(Maybe (c p a))+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Data, Typeable)++instance ( NFData (c p a)+ , NFData p+ , NFData a+ ) => NFData (MapChildren c p a)++instance ( Arbitrary a+ , Arbitrary p+ , Arbitrary (c p a)+ ) => Arbitrary (MapChildren c p a) where+ arbitrary = MapChildren <$> arbitrary <*> scale (\n -> floor $ fromIntegral n / 2) arbitrary++instance ( Monoid (c p a)+ ) => Monoid (MapChildren c p a) where+ mempty = MapChildren Nothing Nothing+ mappend (MapChildren mx mxs) (MapChildren my mys) =+ MapChildren (getLast $ Last mx <> Last my)+ (mxs <> mys)++ newtype MapStep c p a = MapStep- { unMapStep :: Map.Map p (Maybe a, Maybe (c p a))+ { unMapStep :: Map.Map p (MapChildren c p a) } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic, Data, Typeable) instance ( NFData (c p a)@@ -46,26 +70,32 @@ , NFData a ) => NFData (MapStep c p a) -instance (Arbitrary a, Arbitrary p, Arbitrary (c p a), Ord p) => Arbitrary (MapStep c p a) where+instance ( Arbitrary a+ , Arbitrary p+ , Arbitrary (c p a)+ , Ord p+ ) => Arbitrary (MapStep 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+ xs <- replicateM i $ (,) <$> arbitrary <*> resize (floor $ fromIntegral n / 2) arbitrary return $ MapStep $ Map.fromList xs -- | No insertion instance - requires children nodes to be a monoid. Use @Data.Trie.Map.insert@ -- instead.-instance (Ord p, Trie NonEmpty p c) => Trie NonEmpty p (MapStep c) where+instance ( Ord p+ , Trie NonEmpty p c+ ) => Trie NonEmpty p (MapStep c) where lookup (p:|ps) (MapStep xs)- | F.null ps = fst =<< Map.lookup p xs- | otherwise = lookup (NE.fromList ps) =<< snd =<< Map.lookup p xs+ | F.null ps = mapNode =<< Map.lookup p xs+ | otherwise = lookup (NE.fromList ps) =<< mapChildren =<< 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- | otherwise = let (mx,mxs) = fromMaybe (Nothing,Nothing) $ Map.lookup p xs- in MapStep $ Map.insert p (mx, delete (NE.fromList ps) <$> mxs) xs+ | F.null ps = let mxs = mapChildren =<< Map.lookup p xs+ in MapStep $! Map.insert p (MapChildren Nothing mxs) xs+ | otherwise = let (MapChildren mx mxs) = fromMaybe (MapChildren Nothing Nothing) $! Map.lookup p xs+ in MapStep $! Map.insert p (MapChildren mx $! delete (NE.fromList ps) <$> mxs) xs insert :: ( Ord p@@ -73,34 +103,38 @@ , Monoid (c p a) ) => NonEmpty p -> a -> MapStep c p a -> MapStep c p a 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- 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+ | F.null ps = let mxs = mapChildren =<< Map.lookup p xs+ in MapStep $! Map.insert p (MapChildren (Just x) mxs) xs+ | otherwise = let mx = mapNode =<< Map.lookup p xs+ xs' = fromMaybe mempty (mapChildren =<< Map.lookup p xs)+ in MapStep $! Map.insert p (MapChildren mx $ Just $! Data.Trie.Class.insert (NE.fromList ps) x xs') xs +{-# INLINEABLE insert #-} -instance (Ord s, Monoid (c s a)) => Monoid (MapStep c s a) where++instance ( Ord s+ , Monoid (c s a)+ ) => Monoid (MapStep c s a) where mempty = empty- mappend (MapStep xs) (MapStep ys) = MapStep $ Map.unionWith go xs ys- where go (mx,mxs) (my,mys) = (getLast $ Last mx <> Last my, mxs <> mys)+ mappend (MapStep xs) (MapStep ys) =+ MapStep $ Map.unionWith (<>) xs ys empty :: MapStep c s a empty = MapStep Map.empty singleton :: s -> a -> MapStep c s a-singleton p x = MapStep $ Map.singleton p (Just x, Nothing)+singleton p x = MapStep $ Map.singleton p $ MapChildren (Just x) Nothing -- * Fixpoint of Steps newtype MapTrie s a = MapTrie- { unMapTrie :: MapStep MapTrie s a }- deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Monoid, Arbitrary)+ { unMapTrie :: MapStep MapTrie s a+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Monoid, Arbitrary) instance Ord s => Trie NonEmpty s MapTrie where- lookup ts (MapTrie xs) = lookup ts xs- delete ts (MapTrie xs) = MapTrie $ delete ts xs+ lookup ts (MapTrie xs) = lookup ts xs+ delete ts (MapTrie xs) = MapTrie $ delete ts xs insert ts x (MapTrie xs) = MapTrie $ Data.Trie.Map.insert ts x xs type instance K.Key (MapTrie s) = NonEmpty s@@ -114,11 +148,14 @@ -- * Conversion keys :: Ord s => MapTrie s a -> [NonEmpty s]-keys (MapTrie (MapStep xs)) = let ks = Map.keys xs- in F.concatMap go ks- where go k = let (_,mxs) = fromJust $ Map.lookup k xs- in fmap (k :|) $ fromMaybe [] $ do xs' <- mxs- return $ NE.toList <$> keys xs'+keys (MapTrie (MapStep xs)) =+ let ks = Map.keys xs+ in F.concatMap go ks+ where+ go k = let (MapChildren _ mxs) = fromJust $ Map.lookup k xs+ in fmap (k :|) $ fromMaybe [] $ do+ xs' <- mxs+ return $ NE.toList <$> keys xs' elems :: MapTrie s a -> [a] elems = F.toList@@ -127,13 +164,13 @@ subtrie :: Ord s => NonEmpty s -> MapTrie s a -> Maybe (MapTrie s a) subtrie (p:|ps) (MapTrie (MapStep xs))- | F.null ps = snd =<< Map.lookup p xs- | otherwise = subtrie (NE.fromList ps) =<< snd =<< Map.lookup p xs+ | F.null ps = mapChildren =<< Map.lookup p xs+ | otherwise = subtrie (NE.fromList ps) =<< mapChildren =<< Map.lookup p xs -- lookupNearest ~ match match :: Ord s => NonEmpty s -> MapTrie s a -> Maybe (NonEmpty s, a, [s]) match (p:|ps) (MapTrie (MapStep xs)) = do- (mx,mxs) <- Map.lookup p xs+ (MapChildren mx mxs) <- Map.lookup p xs let mFoundHere = do x <- mx return (p:|[], x, ps) if F.null ps then mFoundHere@@ -145,7 +182,9 @@ -- query, in order of the path walked from the root to the furthest point. matches :: Ord s => NonEmpty s -> MapTrie s a -> [(NonEmpty s, a, [s])] matches (p:|ps) (MapTrie (MapStep xs)) =- let (mx,mxs) = fromMaybe (Nothing,Nothing) $ Map.lookup p xs+ let (MapChildren mx mxs) =+ fromMaybe (MapChildren Nothing Nothing) $+ Map.lookup p xs foundHere = fromMaybe [] $ do x <- mx return [(p:|[],x,ps)] in if F.null ps then foundHere
tries.cabal view
@@ -1,5 +1,5 @@ Name: tries-Version: 0.0.3+Version: 0.0.4 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3