COMMENT:----------------------- Compile me with ghc -c -O -fglasgow-exts Trie.lhs ------------------------------- Tries > module Trie ( Trie, > -- construction > empty, singleton, union, unionMany, > add, (///), > -- construction with combining function > -- modification > delete, deleteMany, minus, > -- conversion > toList, fromList, > -- size > genericLengthTrie, lengthTrie, > -- testing > nullTrie, isSingleton, > -- extraction > elemsTrie, indicesTrie, > -- lookup > lookup, lookupWithDefault, > lookupWithContinuation, > -- *additional functions* > prefixLookup > ) > where > import Subsequences ( isPrefixOf ) > applyWithDefault :: (a -> Maybe b) -> b -> a -> b > applyWithDefault f def a = case f a of Nothing -> def; Just v -> v > applyWithContinuation :: (a -> Maybe b) -> (b -> c) -> c -> a -> c > applyWithContinuation f succ err a > = case f a of Nothing -> err; Just v -> succ v > import Support ( applyWithDefault, applyWithContinuation ) Type definition > data Trie a b = Leaf [a] b -- leaf node > | Node [(a,Trie a b)] (Maybe b) -- inner node > deriving () The value associated with the empty sequence is contained in the Maybe b part. Note: Node [('a',empty)] Nothing is not legal. A trie is printed as a set of bindings of the form a |-> v. > instance (Show a, Show b) => Show (Trie a b) where > showsPrec d t = showBinds (toList t) > where showBinds [] = showString "{}" > showBinds (b:x) = showChar '{' . showBind b . showl x > showl [] = showChar '}' > showl (b:x) = showString ", " . showBind b . showl x > showBind (a,v) = shows a . showString " |-> " . shows v Further instances: Eq, Ord, ...? Construction empty constructs an empty trie. > empty :: Trie a b > empty = Node [] Nothing > singleton :: ([a],b) -> Trie a b > singleton (x,v) = Leaf x v union and unionMany are quick hacks. > union :: Ord a => Trie a b -> Trie a b -> Trie a b > union t1 t2 = t1 /// toList t2 > unionMany :: Ord a => [Trie a b] -> Trie a b > unionMany = foldl union empty > add :: Ord a => ([a],b) -> Trie a b -> Trie a b > add (x,v) t = insert t x v Note: /// instead of //. > (///) :: Ord a => Trie a b -> [([a],b)] -> Trie a b > t /// xvs = foldl (flip add) t xvs Construction with combining function ToDo: union_C, unionMany_C, add_C, addMany_C. Modification ToDo: intersect. > delete :: Ord a => Trie a b -> [a] -> Trie a b > delete t@(Leaf y w) x > | x==y = empty > | otherwise = t > delete (Node ts w) [] = Node ts Nothing > delete (Node ts w) (a:x) = Node (delList ts) w > where > delList [] = [] > delList ts@((b,t):us) = case compare b a of > LT -> (b,t):delList us > EQ -> case delete t x of > Node [] Nothing -> us -- rm empty node > u -> (b,u):us > GT -> ts > deleteMany :: Ord a => Trie a b -> [[a]] -> Trie a b > deleteMany = foldl delete minus is a quick hack. > minus :: Ord a => Trie a b -> Trie a b -> Trie a b > minus t1 t2 = t1 `deleteMany` indicesTrie t2 ToDo: amap, partition, filter, foldl, foldr. Conversion > toList :: Trie a b -> [([a],b)] > toList t = toLists [] t [] > toLists s (Leaf x v) = put (reverseTo s x, v) > toLists s (Node ts w) = puts [ (reverse s, v) | Just v<-[w] ] > . compose [ toLists (a:s) t | (a,t)<-ts ] toList (Leaf x w) = [ (x,w) ] toList (Node ts w) = [ ([],v) | Just v<-[w] ] ++ [ (a:x,w) | (a,t)<-ts, (x,w)<-toList t ] fromList is a quick hack. > fromList :: Ord a => [([a],b)] -> Trie a b > fromList = foldl (flip add) empty Size Note: genericLengthTrie instead of genericLength. Dito: lengthTrie. > genericLengthTrie :: Integral a => Trie b c -> a > genericLengthTrie (Leaf x w) = 1 > genericLengthTrie (Node ts w) = sum [ genericLengthTrie t | (a,t)<-ts ]+len w > where len Nothing = 0 > len (Just _) = 1 > lengthTrie :: Trie a b -> Int > lengthTrie = genericLengthTrie Testing Note: nullTrie instead of null. > nullTrie :: Trie a b -> Bool > nullTrie (Node [] Nothing) = True > nullTrie _ = False > isSingleton :: Trie a b -> Bool > isSingleton (Leaf x v) = True > isSingleton (Node [] (Just v)) = True > isSingleton (Node [(a,t)] Nothing) = isSingleton t > isSingleton _ = False ToDo: intersecting, subsetT. Extraction Note: elemsTrie instead of elems. Dito: indicesTrie. > elemsTrie :: Trie a b -> [b] > elemsTrie = map snd . toList > indicesTrie :: Trie a b -> [[a]] > indicesTrie = map fst . toList Lookup > tlookup :: Ord a => Trie a b -> [a] -> Maybe b > tlookup (Leaf y w) x > | x==y = Just w > | otherwise = Nothing > tlookup (Node ts w) [] = w > tlookup (Node ts w) (a:x) = lookupList ts > where > lookupList [] = Nothing > lookupList ((b,t):ts) = case compare b a of > LT -> lookupList ts > EQ -> tlookup t x > GT -> Nothing > lookupWithDefault :: Ord a => Trie a b -> b -> [a] -> b > lookupWithDefault = applyWithDefault . tlookup > lookupWithContinuation :: Ord a => Trie a b -> (b -> c) -> c -> [a] -> c > lookupWithContinuation = applyWithContinuation . tlookup Additional functions prefixLookup returns the list of all completions of the given list. > prefixLookup :: Ord a => Trie a b -> [a] -> [([a],b)] > prefixLookup (Leaf y w) x = [ (drop (length x) y,w) | x `isPrefixOf` y ] > prefixLookup t@(Node _ _) [] = toList t > prefixLookup (Node ts _) (a:x)= lookupList ts > where > lookupList [] = [] > lookupList ((b,t):ts) = case compare b a of > LT -> lookupList ts > EQ -> prefixLookup t x > GT -> [] Auxiliary functions Insert an element into a trie. An existing entry is shadowed by the new entry. > insert :: Ord a => Trie a b -> [a] -> b -> Trie a b > insert (Leaf [] _) [] v = Leaf [] v > insert (Leaf (b:y) w) [] v = Node [(b,Leaf y w)] (Just v) > insert (Leaf [] w) (a:x) v = Node [(a,Leaf x v)] (Just w) > insert (Leaf (b:y) w) (a:x) v = case compare b a of > LT -> Node [(b,Leaf y w),(a,Leaf x v)] Nothing > EQ -> Node [(a,insert (Leaf y w) x v)] Nothing > GT -> Node [(a,Leaf x v),(b,Leaf y w)] Nothing > insert (Node ts w) [] v = Node ts (Just v) > insert (Node ts w) (a:x) v = Node (insList ts) w > where > insList [] = [(a,Leaf x v)] > insList ((b,t):ts) = case compare b a of > LT -> (b,t):insList ts > EQ -> (b,insert t x v):ts > GT -> (a,Leaf x v):(b,t):ts > compose = foldr (.) id > put = (:) > puts = (++) > reverseTo [] y = y > reverseTo (a:x) y = reverseTo x (a:y)