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  )
> 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 (Text a, Text b) => Text (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 _tagCmp 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

> lookup                        :: Ord a => Trie a b -> [a] -> Maybe b
> lookup (Leaf y w) x
>     | x==y                    =  Just w
>     | otherwise               =  Nothing
> lookup (Node ts w) []         =  w
> lookup (Node ts w) (a:x)      =  lookupList ts
>     where
>     lookupList []             =  Nothing
>     lookupList ((b,t):ts)     =  case _tagCmp b a of
>         _LT                   -> lookupList ts
>         _EQ                   -> lookup t x
>         _GT                   -> Nothing

> lookupWithDefault             :: Ord a => Trie a b -> b -> [a] -> b
> lookupWithDefault             =  applyWithDefault . lookup

> lookupWithContinuation        :: Ord a => Trie a b -> (b -> c) -> c -> [a] ->c
> lookupWithContinuation        =  applyWithContinuation . lookup

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 _tagCmp 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 _tagCmp 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 _tagCmp 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)