tries (empty) → 0.0.1
raw patch · 8 files changed
+646/−0 lines, 8 filesdep +basedep +bytestringdep +bytestring-trie
Dependencies added: base, bytestring, bytestring-trie, composition, composition-extra, containers, criterion, keys, mtl, rose-trees, semigroups, sets, tries
Files
- LICENSE +30/−0
- bench/Bench.hs +59/−0
- src/Data/Trie/Class.hs +58/−0
- src/Data/Trie/Knuth.hs +48/−0
- src/Data/Trie/List.hs +34/−0
- src/Data/Trie/Map.hs +134/−0
- src/Data/Trie/Pseudo.hs +225/−0
- tries.cabal +58/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Athan Clark++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Athan Clark nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ bench/Bench.hs view
@@ -0,0 +1,59 @@+module Main where++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.Trie.Class as TC+import qualified Data.Map as Map+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++++main = defaultMain+ [ bgroup "lookup"+ [ bgroup "ListTrie"+ [ bench "1" $ whnf (L.lookup $ 0 :| [100]) (genListTrie 100)+ , bench "2" $ whnf (L.lookup $ 0 :| [100,99..81]) (genListTrie 100)+ , bench "3" $ whnf (L.lookup $ 0 :| [100,99..61]) (genListTrie 100)+ , bench "4" $ whnf (L.lookup $ 0 :| [100,99..41]) (genListTrie 100)+ , bench "5" $ whnf (L.lookup $ 0 :| [100,99..21]) (genListTrie 100)+ , bench "6" $ whnf (L.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)+ ]+ ]+ ]
+ src/Data/Trie/Class.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE+ MultiParamTypeClasses+ , FunctionalDependencies+ #-}++module Data.Trie.Class where++import Prelude hiding (lookup)+import qualified Data.Trie as BT+import qualified Data.ByteString as BS++import Data.Function.Syntax+import Data.Maybe (isJust, fromMaybe)+import Data.Monoid+import Data.Foldable as F+import Data.Functor.Identity (Identity (..))+++-- | Class representing tries with single-threaded insertion, deletion, and lookup.+-- @forall ts ps a. isJust $ lookupPath ps (insertPath ps a ts)@+-- @forall ts ps. isNothing $ lookupPath ps (deletePath ps ts)@+class Trie p s t | t -> p where+ lookup :: p s -> t s a -> Maybe a+ insert :: p s -> a -> t s a -> t s a+ delete :: p s -> t s a -> t s a++lookupWithDefault :: Trie p s t => a -> p s -> t s a -> a+lookupWithDefault x = fromMaybe x .* lookup++++member :: Trie p s t => p s -> t s a -> Bool+member = isJust .* lookup++notMember :: Trie p s t => p s -> t s a -> Bool+notMember = not .* member++-- * Conversion++fromFoldable :: (Foldable f, Monoid (t s a), Trie p s t) => f (p s, a) -> t s a+fromFoldable = F.foldr (uncurry insert) mempty+++-- * ByteString-Trie++-- | Embeds an empty ByteString passed around for type inference.+newtype BSTrie q a = BSTrie {unBSTrie :: (q, BT.Trie a)}++makeBSTrie :: BT.Trie a -> BSTrie BS.ByteString a+makeBSTrie x = BSTrie (mempty,x)++getBSTrie :: BSTrie BS.ByteString a -> BT.Trie a+getBSTrie (BSTrie (_,x)) = x++instance Trie Identity BS.ByteString BSTrie where+ lookup = (BT.lookup *. snd . unBSTrie) . runIdentity+ insert (Identity ps) x (BSTrie (q,xs)) = BSTrie (q, BT.insert ps x xs)+ delete (Identity ps) (BSTrie (q,xs)) = BSTrie (q, BT.delete ps xs)
+ src/Data/Trie/Knuth.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE+ DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , GeneralizedNewtypeDeriving+ , FlexibleInstances+ , MultiParamTypeClasses+ #-}++module Data.Trie.Knuth where++import Prelude hiding (lookup)+import Data.Tree.Knuth.Forest (KnuthForest (..))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++import Data.Trie.Class+++newtype KnuthTrie s x = KnuthTrie+ {unKnuthTrie :: KnuthForest (s, Maybe x)}+ deriving (Show, Eq, Functor, Foldable, Traversable)++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+ 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+ insert tss@(t:|ts) x (KnuthTrie (Fork s@(t',mx) 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+ | otherwise = KnuthTrie $ Fork s cs $ unKnuthTrie $ insert tss x $ KnuthTrie ss++ delete _ xs@(KnuthTrie Nil) = xs+ delete tss@(t:|ts) (KnuthTrie (Fork s@(t',mx) cs ss))+ | 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+ | otherwise = KnuthTrie $ Fork s cs $ unKnuthTrie $ delete tss $ KnuthTrie ss
+ src/Data/Trie/List.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE+ TypeFamilies+ , DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , GeneralizedNewtypeDeriving+ #-}++module Data.Trie.List where++import Prelude hiding (lookup)+import Data.Tree (Tree (..))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE++import Data.Key hiding (lookup)+import Data.Monoid+import Control.Monad+++newtype ListTrie t x = ListTrie+ { unListTrie :: Tree (t, Maybe x)+ } deriving (Show, Eq, Functor, Foldable, Traversable)++type instance Key (ListTrie t) = NonEmpty t+-- TODO: Trie instance++++lookup :: Eq t => NonEmpty t -> ListTrie t x -> Maybe x+lookup (t:|ts) (ListTrie (Node (t',mx) xs)) = do+ guard $ t == t'+ if null ts then mx+ else getFirst $ foldMap (First . lookup (NE.fromList ts) . ListTrie) xs
+ src/Data/Trie/Map.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE+ DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , GeneralizedNewtypeDeriving+ , TupleSections+ , TypeFamilies+ , FlexibleInstances+ , FlexibleContexts+ , MultiParamTypeClasses+ #-}++module Data.Trie.Map where++import Data.Trie.Class++import Prelude hiding (lookup, null)+import qualified Data.Map as Map+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+++-- * 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)+++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+ 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,mxs) = fromMaybe (Nothing,Nothing) $ Map.lookup p xs+ in MapStep $ Map.insert p (mx, insert (NE.fromList ps) x <$> mxs) 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+++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)++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)+++-- * Fixpoint of Steps++newtype MapTrie s a = MapTrie+ { unMapTrie :: MapStep MapTrie s a }+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Monoid, Trie NonEmpty s)++type instance K.Key (MapTrie s) = NonEmpty s++-- instance K.Keyed (MapTrie t) where+ -- mapWithKey++instance Ord s => K.Lookup (MapTrie s) where+ lookup = lookup++-- * 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'++elems :: MapTrie s a -> [a]+elems = F.toList++-- * Query++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++-- 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+ let mFoundHere = do x <- mx+ return (p:|[], x, ps)+ if F.null ps then mFoundHere+ else getFirst $ First (do (pre,y,suff) <- match (NE.fromList ps) =<< mxs+ return (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 :: 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+ foundHere = fromMaybe [] $ do x <- mx+ return [(p:|[],x,ps)]+ 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)+++--+-- lookupVia :: Ord t => (t -> Map.Map t (Maybe x, Maybe (MapTrie t x)) -> Maybe (t, (Maybe x, Maybe (MapTrie t x))))+-- -> NonEmpty t -> MapTrie t x -> Maybe (NonEmpty t, x)+-- lookupVia f (t:|ts) (MapTrie xs) = case ts of+-- [] -> do (_,(mx,_)) <- f t xs+-- x <- mx+-- return (t:|[],x)+-- _ -> do (_,(_,mxs)) <- Map.lookupLT t xs+-- lookupVia f (NE.fromList ts) =<< mxs+--
+ src/Data/Trie/Pseudo.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE+ DeriveFunctor+ , DeriveFoldable+ , DeriveTraversable+ , FlexibleInstances+ , ScopedTypeVariables+ #-}++module Data.Trie.Pseudo where++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 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)+++-- TODO: difference+-- | Tagged rose tree with explicit emptyness+data PseudoTrie t a = More t (Maybe a) (NonEmpty (PseudoTrie t a))+ | Rest (NonEmpty t) a+ | Nil+ deriving (Show, Eq, Functor, Foldable, Traversable)++-- | Overwriting instance+instance (Eq t) => Monoid (PseudoTrie t a) where+ mempty = Nil+ mappend = merge++beginsWith :: (Eq t) => PseudoTrie t a -> t -> Bool+beginsWith Nil _ = False+beginsWith (Rest (t:|_) _) p = t == p+beginsWith (More t _ _) p = t == p++-- | Provides a form of deletion by setting a path to @Nothing@, but doesn't+-- cleanup like @prune@+assign :: (Eq t) => NonEmpty t -> Maybe a -> PseudoTrie t a -> PseudoTrie t a+assign ts (Just x) Nil = Rest ts x+assign _ Nothing Nil = Nil+assign tss@(t:|ts) mx ys@(Rest pss@(p:|ps) y)+ | tss == pss = case mx of+ (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+ (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 $+ [ Rest (NE.fromList ps) y+ , Rest (NE.fromList ts) x+ ]+ | otherwise = ys+assign (t:|ts) mx y@(More p my ys)+ | t == p = case ts of+ [] -> More p mx ys+ _ -> More p my $ fmap (assign (NE.fromList ts) mx) ys+ | otherwise = y++-- | Overwrite the LHS point-wise with the RHS's contents+merge :: (Eq t) => PseudoTrie t a -> PseudoTrie t a -> PseudoTrie t a+merge Nil y = y+merge x Nil = x+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) :| []+ | otherwise = xx+merge xx@(More t mx xs) (More p my ys)+ | t == p = More p my $ NE.fromList $+ foldr go [] $ NE.toList xs ++ NE.toList ys+ | otherwise = xx+ where+ 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)+ | 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)+ | t == p = case ts of+ [] -> More p (Just x) ys+ _ -> More p my $+ fmap (merge $ Rest (NE.fromList ts) x) ys+ | otherwise = xx+++add :: (Eq t) => NonEmpty t -> PseudoTrie t a -> PseudoTrie t a -> PseudoTrie t a+add ts input container =+ let ts' = NE.toList ts in+ merge container $ mkMores ts' input+ where+ mkMores :: (Eq t) => [t] -> PseudoTrie t a -> PseudoTrie t a+ mkMores [] trie = trie+ mkMores (t:ts) trie = More t Nothing $+ mkMores ts 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 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+ go depth acc (More t (Just x) xs) =+ (NE.fromList $ depth ++ [t], x) :+ (foldr $ flip $ go $ depth ++ [t]) acc (NE.toList xs)++fromAssocs :: (Eq t) => [(NonEmpty t, a)] -> PseudoTrie t a+fromAssocs = foldr (uncurry assign) Nil . fmap (second Just)++lookup :: (Eq t) => NonEmpty t -> PseudoTrie t a -> Maybe a+lookup _ Nil = Nothing+lookup tss (Rest pss a)+ | tss == pss = Just a+ | otherwise = Nothing+lookup tss@(t:|ts) (More p mx xs)+ | t == p = case ts of+ [] -> mx+ (t':ts') -> 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++-- | Simple test on the heads of two tries+areDisjoint :: (Eq t) => PseudoTrie t a -> PseudoTrie t a -> Bool+areDisjoint (More t _ _) (More p _ _)+ | t == p = False+ | otherwise = True+areDisjoint (Rest (t:|_) _) (Rest (p:|_) _)+ | t == p = False+ | otherwise = True+areDisjoint _ _ = True++-- | The meet of two @PseudoTrie@s+intersectionWith :: (Eq t) =>+ (a -> b -> c)+ -> PseudoTrie t a+ -> PseudoTrie t b+ -> PseudoTrie t c+intersectionWith _ _ Nil = Nil+intersectionWith _ Nil _ = Nil+intersectionWith f (Rest tss@(t:|ts) x) (Rest pss@(p:|ps) y)+ | tss == pss = Rest pss $ f x y+ | otherwise = Nil+intersectionWith f (More t mx xs) (More p my ys)+ | t == p = case [intersectionWith f x' y' | x' <- NE.toList xs, y' <- NE.toList ys] of+ [] -> case f <$> mx <*> my of+ Nothing -> Nil+ Just c -> Rest (p :| []) c+ zs -> More p (f <$> mx <*> my) $ NE.fromList zs+ -- implicit root+ | otherwise = Nil+intersectionWith f (More t mx xs) (Rest pss@(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)+ | t == p = case ts of+ [] -> case f <$> Just x <*> my of+ Nothing -> Nil+ Just c -> Rest (t :| []) c+ _ -> More t Nothing $ fmap (intersectionWith f $ Rest (fromList ts) x) ys+ | otherwise = Nil++-- difference :: Eq t =>+-- PseudoTrie t a+-- -> PseudoTrie t a+-- -> PseudoTrie t a+++-- | Needless intermediary elements are turned into shortcuts, @Nil@'s in+-- subtrees are also removed.+prune :: PseudoTrie t a -> PseudoTrie t a+prune = go+ where+ go Nil = Nil+ go xx@(Rest ts x) = xx+ go (More t Nothing xs) =+ case cleaned xs of+ [Nil] -> Nil+ [Rest ts x] -> Rest (t:|NE.toList ts) x+ xs' -> More t Nothing $ NE.fromList xs'+ go (More t (Just x) xs) =+ case cleaned xs of+ [Nil] -> Rest (t:|[]) x+ xs' -> More t (Just x) $ NE.fromList xs'++ cleaned xs = removeNils (NE.toList $ fmap go xs)++ removeNils xs = case removeNils' xs of+ [] -> [Nil]+ ys -> ys+ where+ removeNils' [] = []+ removeNils' (Nil:xs) = removeNils' xs+ removeNils' (x:xs) = x : removeNils' xs
+ tries.cabal view
@@ -0,0 +1,58 @@+Name: tries+Version: 0.0.1+Author: Athan Clark <athan.clark@gmail.com>+Maintainer: Athan Clark <athan.clark@gmail.com>+License: BSD3+License-File: LICENSE+Synopsis: Various trie implementations in Haskell+-- Description:+Cabal-Version: >= 1.10+Build-Type: Simple+Category: Data, Tree++Library+ Default-Language: Haskell2010+ HS-Source-Dirs: src+ GHC-Options: -Wall+ Exposed-Modules: Data.Trie.Class+ Data.Trie.Knuth+ Data.Trie.List+ Data.Trie.Map+ Data.Trie.Pseudo+ Build-Depends: base >= 4.6 && < 5+ , containers+ , bytestring+ , bytestring-trie+ , semigroups+ , rose-trees >= 0.0.2+ , composition+ , composition-extra >= 2.0.0+ , keys+ , sets >= 0.0.5+ , mtl+ , criterion++Benchmark bench+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: src+ , bench+ Ghc-Options: -Wall+ Main-Is: Bench.hs+ Build-Depends: base+ , tries+ , criterion+ , containers+ , bytestring+ , bytestring-trie+ , semigroups+ , rose-trees+ , composition+ , composition-extra+ , keys+ , sets+ , mtl++Source-Repository head+ Type: git+ Location: https://github.com/athanclark/tries.git