adict 0.2.0 → 0.3.0

raw patch · 15 files changed

+494/−384 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• NLP/Adict.hs +51/−23
• NLP/Adict/Basic.hs +11/−11
• NLP/Adict/Brute.hs +4/−3
• NLP/Adict/Core.hs +1/−1
• NLP/Adict/CostDiv.hs +51/−20
• NLP/Adict/DAWG.hs +6/−118
• NLP/Adict/DAWG/Internal.hs +122/−0
• NLP/Adict/DAWG/Node.hs +0/−22
• NLP/Adict/Graph.hs +4/−4
• NLP/Adict/Nearest.hs +10/−6
• NLP/Adict/Node.hs +24/−0
• NLP/Adict/Trie.hs +7/−160
• NLP/Adict/Trie/Internal.hs +188/−0
• adict.cabal +9/−7
• tests/Properties.hs +6/−9

@@ -1,4 +1,4 @@--- | This module exports main data types and functions of the adict library.+-- | This module re-exports main data types and functions from the adict library.  module NLP.Adict (@@ -7,20 +7,39 @@  -- ** Trie   Trie (..)-, TrieD+, TrieM , fromList , implicitDAWG  -- ** Directed acyclic word graph , DAWG (..)-, Row (..)-, DAWGD+, Node (..)+, DAWGM , fromTrie , fromDAWG++-- * Approximate searching +-- $searching++-- ** Cost function +, Word+, Pos+, Weight+, Cost (..)+, costDefault++-- ** Searching methods+, bruteSearch+, findAll+, findNearest ) where -import NLP.Adict.Trie (Trie (..), TrieD, fromList, implicitDAWG)-import NLP.Adict.DAWG (DAWG (..), Row (..), DAWGD, fromTrie, fromDAWG)+import NLP.Adict.Core (Word, Pos, Weight, costDefault, Cost (..))+import NLP.Adict.Trie (Trie (..), TrieM, fromList, implicitDAWG)+import NLP.Adict.DAWG (DAWG (..), Node (..), DAWGM, fromTrie, fromDAWG)+import NLP.Adict.Brute (bruteSearch)+import NLP.Adict.Basic (findAll)+import NLP.Adict.Nearest (findNearest)  {- $data-structures @@ -42,20 +61,29 @@  -} ---   2. Approximate search and cost representation---    * Plain cost function---    * Cost components divided with respect to weight--- ---   There are to ways of representing the cost function, depending on---   the searching algorithm you are planning to use.  If you want to---   find all matches within the given distance of the query word,---   use the 'findAll' function with cost function represented by the---   'Cost' structure.--- ---   If, however, only the nearest match is needed you can use the---   'findNearest' function. The shortest-path-search algorithm in the---   background is optimized to use the more find-grained, 'CostDiv'---   structure for cost representation. See the '...' module for the---   details about how such a cost function can be constructed.--- --- -}+{- $searching++  There are three approximate searching methods implemented in+  the library.  The first one, 'findAll', can be used to find+  all matches within the given distance from the query word.+  The 'findNearest' function, on the other hand, searches only+  for the nearest to the query word match.  +  The third one, 'bruteSearch', is provided only for reference+  and testing purposes.++  The 'findAll' function is evaluated against the 'Trie' while the+  'findNearest' one is evaluated against the 'DAWG'.+  The reason to make this distinction is that the 'findNearest'+  function needs to distinguish between DAG nodes and to know+  when the particular node is visited for the second time.++  Both methods perform the search with respect to the cost function+  specified by the library user, which can be used to customize+  weights of edit operations.  The 'Cost' structure provides the+  general representation of the cost and it can be used with+  the 'findAll' method.   The shortest-path algorithm used in+  the background of the 'findNearest' function is optimized to +  use the more informative, 'CostDiv' cost representation,+  which divides edit operations between separate classes with+  respect to their weight.+-}

@@ -1,5 +1,5 @@ module NLP.Adict.Basic-( search+( findAll ) where  import Data.Ix (range)@@ -7,23 +7,23 @@ import qualified Data.Vector as V  import NLP.Adict.Core-import NLP.Adict.Trie hiding (insert)+import NLP.Adict.Trie.Internal hiding (insert)  -- | Find all words within a trie with restricted generalized edit distance -- lower or equall to k.-search :: Cost a -> Double -> Word a -> TrieD a b -> [([a], b, Double)]-search cost k x trie =+findAll :: Cost a -> Double -> Word a -> TrieM a b -> [([a], b, Double)]+findAll cost k x trie =     foundHere ++ foundLower   where     foundHere-        | dist' m <= k = case valueIn trie of+        | dist' m <= k = case rootValue trie of             Just y  -> [([], y, dist' m)]             Nothing -> []         | otherwise = []     foundLower         | minimum (A.elems distV) > k = []         | otherwise = concatMap searchLower $ anyChild trie-    searchLower = search' cost k dist' x+    searchLower = search cost k dist' x      dist' = (A.!) distV      distV = A.array bounds [(i, dist i) | i <- range bounds]@@ -33,20 +33,20 @@     dist 0 = 0     dist i = dist' (i-1) + (delete cost) i (x#i) -search' :: Cost a -> Double -> (Int -> Double)-        -> Word a -> (a, TrieD a b) -> [([a], b, Double)]-search' cost k distP x (c, trie) =+search :: Cost a -> Double -> (Int -> Double)+       -> Word a -> (a, TrieM a b) -> [([a], b, Double)]+search cost k distP x (c, trie) =     foundHere ++ map appendChar foundLower   where     foundHere-        | dist' m <= k = case valueIn trie of+        | dist' m <= k = case rootValue trie of             Just y  -> [([c], y, dist' m)]             Nothing -> []         | otherwise = []     foundLower         | minimum (A.elems distV) > k = []         | otherwise = concatMap searchLower $ anyChild trie-    searchLower = search' cost k dist' x+    searchLower = search cost k dist' x     appendChar (cs, y, w) = ((c:cs), y, w)      dist' = (A.!) distV 

@@ -1,5 +1,5 @@ module NLP.Adict.Brute-( search+( bruteSearch ) where  import Data.Maybe (mapMaybe)@@ -9,8 +9,9 @@  -- | Find all words within a list with restricted generalized edit distance -- from x lower or equall to k.-search :: Cost a -> Double -> Word a -> [(Word a, b)] -> [(Word a, b, Double)]-search cost k x =+bruteSearch :: Cost a -> Double -> Word a+            -> [(Word a, b)] -> [(Word a, b, Double)]+bruteSearch cost k x =     mapMaybe check   where     check (y, v)

@@ -33,7 +33,7 @@     , delete :: Pos -> a -> Weight     , subst  :: Pos -> a -> a -> Weight } --- | Simple cost function: all edit operations cost 1.+-- | Simple cost function: all edit operations cost 1 unit. costDefault :: Eq a => Cost a costDefault =     Cost _insert _delete _subst

@@ -1,11 +1,16 @@ {-# LANGUAGE RecordWildCards #-} +-- | Alternative cost representation with individual cost components+-- divided into groups with respect to operation weights.  + module NLP.Adict.CostDiv-( Group (..)+(+-- * CostDiv+  Group (..) , CostDiv (..)-, mapWeight , costDefault +-- * Helper functions for CostDiv construction  , Sub , mkSub , unSub@@ -13,6 +18,7 @@ , subOn , mkSubMap +-- * Conversion to standard representation , toCost , toCostInf ) where@@ -22,23 +28,37 @@  import NLP.Adict.Core (Pos, Cost(..), Weight) --- | TODO: Add Choice data contructor together with appropriate--- implementation: Choice Char Weight-data Group a = Filter-    { predic :: a -> Bool-    , weight :: Weight } -mapWeight :: (Weight -> Weight) -> Group a -> Group a-mapWeight f g = g { weight = f (weight g) }-           +-- TODO: Add Choice data contructor.++-- | A Group describes a weight of some edit operation in which a character+-- satistying the predicate is involved.  This data structure is meant to+-- collect all characters which determine the same operation weight.+data Group a = Filter {+    -- | The predicate determines which characters belong to the group.+    predic :: a -> Bool,+    -- | Weight of the edit operation in which a character satisfying the+    -- predicate is involved.+    weight :: Weight  }+ -- | Cost function with edit operations divided with respect to weight.--- Two operations with the same cost should be assigned to the same group.-data CostDiv a = CostDiv-    { insert ::        [Group a]-    , delete :: a   -> Weight-    , subst  :: a   -> [Group a]-    , posMod :: Pos -> Weight }+-- Two operations of the same type and with the same weight should be+-- assigned to the same group.+data CostDiv a = CostDiv {+    -- | Cost of the character insertion divided into groups with+    -- respect to operation weights.+    insert ::        [Group a],+    -- | Cost of the character deletion.+    delete :: a   -> Weight,+    -- | Cost of the character substitution.  For each source character+    -- there can be a different list of groups involved. +    subst  :: a   -> [Group a],+    -- | Cost of each edit operation is multiplied by the position modifier.+    -- For example, the cost of @\'a\'@ character deletion on position @3@+    -- is computed as @delete \'a\' * posMod 3@.+    posMod :: Pos -> Weight } +-- | Default cost with all edit operations having the unit weight. costDefault :: Eq a => CostDiv a costDefault =     CostDiv insert delete subst posMod@@ -55,32 +75,43 @@ {-# INLINABLE costDefault #-} {-# SPECIALIZE costDefault :: CostDiv Char #-} --- | Substition desription for some character x.+-- | Substition description for some unspecified source character. type Sub a = M.Map Weight (S.Set a) +-- | Construct the substitution descrition from the list of (character @y@,+-- substition weight from @x@ to @y@) pairs for some unspecified character+-- @x@.  Characters will be grouped with respect to weight. mkSub :: Ord a => [(a, Weight)] -> Sub a mkSub xs = M.fromListWith S.union [(w, S.singleton x) | (x, w) <- xs] +-- | Extract the list of groups (each group with unique weight) from the+-- substitution description. unSub :: Ord a => Sub a -> [Group a] unSub sub =     [ Filter (`S.member` charSet) weight     | (weight, charSet) <- M.toAscList sub ] --- | Susbtitution map for an alphabet.+-- | A susbtitution map which covers all substition operations. type SubMap a = M.Map a (Sub a) +-- | Substitution description for the given character in the substitution map.+-- In other words, the function returns information how the input character can+-- be replaced with other characters from the alphabet. subOn :: Ord a => a -> SubMap a -> Sub a subOn x sm = case M.lookup x sm of     Just sd -> sd     Nothing -> M.empty +-- | Construct the substitution map from the list of (@x@, @y@, weight of+-- @x -> y@ substitution) tuples. mkSubMap :: Ord a => [(a, a, Weight)] -> SubMap a mkSubMap xs = fmap mkSub $     M.fromListWith (++)         [ (x, [(y, w)])         | (x, y, w) <- xs ] --- | Transform CostDiv to plain Cost function with default weight value.+-- | Transform CostDiv to plain Cost function using the default weight value+-- for all operations unspecified in the input cost. toCost :: Double -> CostDiv a -> Cost a toCost defa CostDiv{..} =     Cost ins del sub@@ -92,7 +123,7 @@     mini xs   = minimum xs  -- | Transform CostDiv to plain Cost function with default weight value--- set to +Infinity.+-- set to @+Infinity@. toCostInf :: CostDiv a -> Cost a toCostInf =     let inf = 1 / 0

@@ -1,125 +1,13 @@ {-# LANGUAGE RecordWildCards #-} +-- | A directed acyclic word graph.+ module NLP.Adict.DAWG-( DAWGD-, DAWG (..)+( DAWG (..)+, Node (..)+, DAWGM , fromTrie , fromDAWG--, size-, row-, Row (..)-, entry-, charOn-, valueIn-, edges-, edgeOn--, serialize-, deserialize ) where -import Control.Applicative ((<$>))-import Data.Maybe (listToMaybe)-import Data.Binary (Binary, get, put)-import qualified Data.Vector as V--import NLP.Adict.DAWG.Node-import qualified NLP.Adict.Trie as Trie---- | A DAWGD dictionary is a 'DAWG' which may have the 'Nothing' value--- along the path from the root to a leave.-type DAWGD a b = DAWG a (Maybe b)---- | A directed acyclic word graph with character type @a@ and dictionary--- entry type @b@.-data DAWG a b = DAWG-    { root  :: Int                  -- ^ Root (index) of the DAWG-    , array :: V.Vector (Row a b)   -- ^ Vector of DAWG nodes-    }---- | Find and eliminate all common subtries in the input trie--- and return the trie represented as a DAWG.-fromTrie :: (Ord a, Ord b) => Trie.Trie a b -> DAWG a b-fromTrie = deserialize . Trie.serialize---- | Transform the DAWG to implicit DAWG in a form of a trie.-fromDAWG :: Ord a => DAWG a b -> Trie.Trie a b-fromDAWG = Trie.deserialize . serialize--size :: DAWG a b -> Int-size = V.length . array-{-# INLINE size #-}--row :: DAWG a b -> Int -> Row a b-row dag k = array dag V.! k-{-# INLINE row #-}---- | A Row represents one node of the DAWG.-data Row a b = Row {-    -- | Value in the node.-    rowValue :: b, -    -- | Edges to subnodes (represented by array indices)-    -- annotated with characters.-    rowEdges :: V.Vector (a, Int)-    }--valueIn :: DAWG a b -> Int -> b-valueIn dag k = rowValue (array dag V.! k)-{-# INLINE valueIn #-}--edges :: DAWG a b -> Int -> [(a, Int)]-edges dag k = V.toList . rowEdges $ row dag k-{-# INLINE edges #-}--edgeOn :: Eq a => DAWG a b -> Int -> a -> Maybe Int-edgeOn DAWG{..} k x =-    let r = array V.! k-    in  snd <$> V.find ((x==).fst) (rowEdges r)--entry :: DAWG a (Maybe b) -> [Int] -> Maybe ([a], b)-entry dag xs = do-    x <- mapM (charOn dag) (zip (root dag:xs) xs)-    r <- maybeLast xs >>= valueIn dag -    return (x, r)-  where-    maybeLast [] = Nothing-    maybeLast ys = Just $ last ys--charOn :: DAWG a b -> (Int, Int) -> Maybe a-charOn dag (root, x) = listToMaybe-    [c | (c, y) <- edges dag root, x == y]--serialize :: Ord a => DAWG a b -> [Node a b]-serialize = map unRow . V.toList . array---- | Assumptiom: root node is last in the serialization list.-deserialize :: Ord a => [Node a b] -> DAWG a b-deserialize xs =-    let arr = V.fromList $ map mkRow xs-    in  DAWG (V.length arr - 1) arr--unRow :: Ord a => Row a b -> Node a b-unRow Row{..} = mkNode rowValue (V.toList rowEdges)-{-# INLINE unRow #-}--mkRow :: Ord a => Node a b -> Row a b-mkRow n = Row (nodeValue n) (V.fromList $ nodeEdges n)-{-# INLINE mkRow #-}--instance (Ord a, Binary a, Binary b) => Binary (DAWG a b) where-    put = put . serialize-    get = deserialize <$> get---- goDown :: DAWG a -> Int -> DAWG a--- goDown DAWG{..} k = DAWG k array--- --- instance T.Trie DAWGArray where---     unTrie dag@DAWGArray{..} =---         let row = array V.! root---         in  ( valueIn row---             , [ (c, goDown dag k)---               | (c, k) <- U.toList (edgeVec row) ] )---     child x dag@DAWGArray{..} =---         let row = array V.! root---         in  goDown dag <$> snd <$> U.find ((x==).fst) (edgeVec row)+import NLP.Adict.DAWG.Internal

@@ -0,0 +1,122 @@+{-# LANGUAGE RecordWildCards #-}++-- | A directed acyclic word graph.++module NLP.Adict.DAWG.Internal+( DAWG (..)+, DAWGM+, fromTrie+, fromDAWG++, size+, nodeBy+, Node (..)+, entry+, charOn+, valueBy+, edges+, edgeOn+) where++import Control.Applicative ((<$>))+import Data.Maybe (listToMaybe)+import Data.Binary (Binary, get, put)+import qualified Data.Vector as V++import qualified NLP.Adict.Node as N+import qualified NLP.Adict.Trie.Internal as Trie++-- | A DAWGM is a 'DAWG' with 'Maybe' values in nodes.+type DAWGM a b = DAWG a (Maybe b)++-- | A directed acyclic word graph with character type @a@ and dictionary+-- entry type @b@.  Each node is represented by a unique integer number+-- which is also an index of the node in the vector of DAWG nodes.+data DAWG a b = DAWG+    { root  :: Int                  -- ^ Root (index) of the DAWG+    , nodes :: V.Vector (Node a b)  -- ^ Vector of DAWG nodes+    }++-- | Find and eliminate all common subtries in the input trie+-- and return the trie represented as a DAWG.+fromTrie :: (Ord a, Ord b) => Trie.Trie a b -> DAWG a b+fromTrie = deserialize . Trie.serialize++-- | Transform the DAWG to implicit DAWG in a form of a trie.+fromDAWG :: Ord a => DAWG a b -> Trie.Trie a b+fromDAWG = Trie.deserialize . serialize++-- | Size of the DAWG.+size :: DAWG a b -> Int+size = V.length . nodes+{-# INLINE size #-}++-- | Node by index.+nodeBy :: DAWG a b -> Int -> Node a b+nodeBy dag k = nodes dag V.! k+{-# INLINE nodeBy #-}++-- | A node in the DAWG.+data Node a b = Node {+    -- | Value in the node.+    valueIn  :: b, +    -- | Edges to subnodes (represented by DAWG node indices)+    -- annotated with characters.+    subNodes :: V.Vector (a, Int)+    }++-- | Value in the DAWG node represented by the index.+valueBy :: DAWG a b -> Int -> b+valueBy dag k = valueIn (nodes dag V.! k)+{-# INLINE valueBy #-}++-- | Edges starting from the DAWG node represented by the index.+edges :: DAWG a b -> Int -> [(a, Int)]+edges dag k = V.toList . subNodes $ nodeBy dag k+{-# INLINE edges #-}++-- | Index of the node following the edge annotated with the+-- given character.+edgeOn :: Eq a => DAWG a b -> Int -> a -> Maybe Int+edgeOn DAWG{..} k x =+    let r = nodes V.! k+    in  snd <$> V.find ((x==).fst) (subNodes r)++-- | Return the dictionary entry determined by following the+-- path of node indices.+entry :: DAWG a (Maybe b) -> [Int] -> Maybe ([a], b)+entry dag xs = do+    x <- mapM (charOn dag) (zip (root dag:xs) xs)+    r <- maybeLast xs >>= valueBy dag +    return (x, r)+  where+    maybeLast [] = Nothing+    maybeLast ys = Just $ last ys++-- | Determine the character on the edges between two nodes.+charOn :: DAWG a b -> (Int, Int) -> Maybe a+charOn dag (root, x) = listToMaybe+    [c | (c, y) <- edges dag root, x == y]++-- | Serialize the DAWG into a list of nodes.+serialize :: Ord a => DAWG a b -> [N.Node a b]+serialize = map unNode . V.toList . nodes++-- | Deserialize the DAWG from a list of nodes.  Assumptiom: root node+-- is last in the serialization list.+deserialize :: Ord a => [N.Node a b] -> DAWG a b+deserialize xs =+    let arr = V.fromList $ map mkNode xs+    in  DAWG (V.length arr - 1) arr++unNode :: Ord a => Node a b -> N.Node a b+unNode Node{..} = N.mkNode valueIn (V.toList subNodes)+{-# INLINE unNode #-}++mkNode :: Ord a => N.Node a b -> Node a b+mkNode n = Node (N.nodeValue n) (V.fromList $ N.nodeEdges n)+{-# INLINE mkNode #-}++instance (Ord a, Binary a, Binary b) => Binary (DAWG a b) where+    put = put . serialize+    get = deserialize <$> get

@@ -1,22 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module NLP.Adict.DAWG.Node-( Node-, mkNode-, nodeValue-, nodeEdges-) where--import Data.Binary (Binary)--newtype Node a b = Node { unNode :: (b, [(a, Int)]) }-    deriving (Show, Eq, Ord, Binary)--mkNode :: b -> [(a, Int)] -> Node a b-mkNode x xs = Node (x, xs)--nodeValue :: Node a b -> b-nodeValue = fst . unNode--nodeEdges :: Node a b -> [(a, Int)]-nodeEdges = snd . unNode

@@ -10,12 +10,12 @@ import qualified Data.PSQueue as P import qualified Data.Map as M --- | Adjacent list for a given node @n. We assume, that the list+-- | Adjacent list for a given node @n@. We assume, that the list -- is given in an ascending order. type Edges n w = n -> [(w, n)] type Edge n w  = (n, w, n) --- | Is @n node an ending node?+-- | Is @n@ node an ending node? type IsEnd n = n -> Bool  -- | Non-empty list of adjacent nodes given in an ascending order.@@ -65,8 +65,8 @@    where -    -- @visited: set of visited nodes-    -- @queue: priority queue+    -- @visited@: set of visited nodes+    -- @queue@: priority queue     shortest visited queue = do         (edge, queue') <- minView queue         shortest' visited queue' edge

@@ -1,5 +1,5 @@ module NLP.Adict.Nearest-( search+( findNearest ) where  import Control.Applicative ((<$>))@@ -12,7 +12,7 @@  import NLP.Adict.Core (Pos, Weight, Word, (#)) import NLP.Adict.CostDiv-import NLP.Adict.DAWG+import NLP.Adict.DAWG.Internal hiding (Node) import NLP.Adict.Graph  type NodeID  = Int@@ -43,13 +43,17 @@ weightOf (Sub g) = weight g {-# INLINE weightOf #-} +mapWeight :: (Weight -> Weight) -> Group a -> Group a+mapWeight f g = g { weight = f (weight g) }+ -- | We can check, if CostDiv satisfies basic properties.  On the other -- hand, we do not do this for plain Cost function.-search :: CostDiv a -> Double -> Word a -> DAWGD a b -> Maybe ([a], b, Double)-search cost z x dag = do+findNearest :: CostDiv a -> Double -> Word a+            -> DAWGM a b -> Maybe ([a], b, Double)+findNearest cost z x dag = do     (xs, w) <- minPath z edgesFrom isEnd (Node (root dag) 0 Nothing)     let form = catMaybes . map nodeChar $ xs-    r <- valueIn dag $ nodeID $ last xs+    r <- valueBy dag $ nodeID $ last xs     return (form, r, w)   where     edgesFrom (Node n i _) =@@ -79,4 +83,4 @@             | (c, m) <- edges dag n             , f c ] -    isEnd (Node n k _) = k == V.length x && isJust (valueIn dag n)+    isEnd (Node n k _) = k == V.length x && isJust (valueBy dag n)

@@ -0,0 +1,24 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-- | A graph node data type.++module NLP.Adict.Node+( Node+, mkNode+, nodeValue+, nodeEdges+) where++import Data.Binary (Binary)++newtype Node a b = Node { unNode :: (b, [(a, Int)]) }+    deriving (Show, Eq, Ord, Binary)++mkNode :: b -> [(a, Int)] -> Node a b+mkNode x xs = Node (x, xs)++nodeValue :: Node a b -> b+nodeValue = fst . unNode++nodeEdges :: Node a b -> [(a, Int)]+nodeEdges = snd . unNode

@@ -1,170 +1,17 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}+-- | A (prefix) trie.  module NLP.Adict.Trie-( TrieD-, Trie (..)-, unTrie-, child-, anyChild-, mkTrie-, setValue-, substChild+( Trie (..)+, TrieM+, empty , insert--, size+, fromList+, toList , follow , lookup , fromLang-, fromList-, toList--, serialize-, deserialize , implicitDAWG ) where  import Prelude hiding (lookup)-import Control.Applicative ((<$>), (<*>))-import Control.Monad ((>=>))-import Data.List (foldl')-import Data.Binary (Binary, get, put)-import qualified Data.Map as M--import NLP.Adict.DAWG.Node---- | A 'Trie' with 'Maybe' values in nodes.-type TrieD a b = Trie a (Maybe b)---- | A trie of words with character type @a@ and entry type @b@.  It can be--- thought of as a map of type @[a] -> b@.-data Trie a b = Trie {-    -- | Value in the node.-    valueIn :: b,                  -    -- | Edges to subtries annotated with characters.-    edgeMap :: M.Map a (Trie a b)-    } deriving (Show, Eq, Ord)--instance Functor (Trie a) where-    fmap f Trie{..} = Trie (f valueIn) (fmap (fmap f) edgeMap)--instance (Ord a, Binary a, Binary b) => Binary (Trie a b) where-    put Trie{..} = do-        put valueIn-        put edgeMap-    get = Trie <$> get <*> get--unTrie :: Trie a b -> (b, [(a, Trie a b)])-unTrie t = (valueIn t, M.toList $ edgeMap t)-{-# INLINE unTrie #-}--child :: Ord a => a -> Trie a b -> Maybe (Trie a b)-child x Trie{..} = x `M.lookup` edgeMap-{-# INLINE child #-}--anyChild :: Trie a b -> [(a, Trie a b)]-anyChild = snd . unTrie-{-# INLINE anyChild #-}--mkTrie :: Ord a => b -> [(a, Trie a b)] -> Trie a b-mkTrie !v !cs = Trie v (M.fromList cs)-{-# INLINE mkTrie #-}--empty :: Ord a => TrieD a b-empty = mkTrie Nothing []-{-# INLINE empty #-}--setValue :: b -> Trie a b -> Trie a b-setValue !x !t = t { valueIn = x }-{-# INLINE setValue #-}--substChild :: Ord a => a -> Trie a b -> Trie a b -> Trie a b-substChild !x !trie !newChild =-    let how _ = Just newChild-        !edges = M.alter how x (edgeMap trie)-    in trie { edgeMap = edges }-{-# INLINABLE substChild #-}-{-# SPECIALIZE substChild-    :: Char-    -> Trie Char b-    -> Trie Char b-    -> Trie Char b #-}--insert :: Ord a => [a] -> b -> TrieD a b -> TrieD a b-insert [] v t = setValue (Just v) t-insert (x:xs) v t = substChild x t . insert xs v $-    case child x t of-        Just t' -> t'-        Nothing -> empty-{-# INLINABLE insert #-}-{-# SPECIALIZE insert-    :: String -> b-    -> TrieD Char b-    -> TrieD Char b #-}--size :: Trie a b -> Int-size t = 1 + sum (map (size.snd) (anyChild t))--follow :: Ord a => [a] -> Trie a b -> Maybe (Trie a b)-follow xs t = foldr (>=>) return (map child xs) t--lookup :: Ord a => [a] -> TrieD a b -> Maybe b-lookup xs t = follow xs t >>= valueIn---- | Construct the 'Trie' from the list of (word, value) pairs.-fromList :: Ord a => [([a], b)] -> TrieD a b-fromList xs =-    let update t (x, v) = insert x v t-    in  foldl' update empty xs--toList :: TrieD a b -> [([a], b)]-toList t = case valueIn t of-    Just y -> ([], y) : lower-    Nothing -> lower-  where-    lower = concatMap goDown $ anyChild t-    goDown (x, t') = map (addChar x) $ toList t'-    addChar x (xs, y) = (x:xs, y)--fromLang :: Ord a => [[a]] -> TrieD a ()-fromLang xs = fromList [(x, ()) | x <- xs]---- | Elminate common subtries.  The result is algebraically a trie--- but is represented as a DAWG in memory.-implicitDAWG :: (Ord a, Ord b) => Trie a b -> Trie a b-implicitDAWG = deserialize . serialize---- | Serialize the trie and eliminate all common subtries--- along the way.  TODO: perhaps the function name should--- be different?-serialize :: (Ord a, Ord b) => Trie a b -> [Node a b]-serialize r =-    [ mkNode (valueIn t)-        [ (c, m M.! s)-        | (c, s) <- anyChild t ]-    | t <- M.elems m' ]-  where-    m  = collect r-    m' = M.fromList [(y, x) | (x, y) <- M.toList m]---- | FIXME: Null node list case.-deserialize :: Ord a => [Node a b] -> Trie a b-deserialize =-    snd . M.findMax . foldl' update M.empty-  where-    update m n =-        let t = mkTrie (nodeValue n) [(c, m M.! k) | (c, k) <- nodeEdges n]-        in  M.insert (M.size m) t m---- | Collect unique tries and assign identifiers to them.-collect :: (Ord a, Ord b) => Trie a b -> M.Map (Trie a b) Int-collect t = collect' M.empty t--collect' :: (Ord a, Ord b) => M.Map (Trie a b) Int-         -> Trie a b -> M.Map (Trie a b) Int-collect' m0 t = M.alter f t m-  where-    !m = foldl' collect' m0 (M.elems $ edgeMap t)-    !k = M.size m-    f Nothing  = Just k-    f (Just x) = Just x+import NLP.Adict.Trie.Internal

@@ -0,0 +1,188 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}++-- | A (prefix) trie.++module NLP.Adict.Trie.Internal+( TrieM+, Trie (..)+, empty+, unTrie+, child+, anyChild+, mkTrie+, setValue+, substChild+, insert++, size+, follow+, lookup+, fromLang+, fromList+, toList++, serialize+, deserialize+, implicitDAWG+) where++import Prelude hiding (lookup)+import Control.Applicative ((<$>), (<*>))+import Control.Monad ((>=>))+import Data.List (foldl')+import Data.Binary (Binary, get, put)+import qualified Data.Map as M++import NLP.Adict.Node++-- | A 'Trie' with 'Maybe' values in nodes.+type TrieM a b = Trie a (Maybe b)++-- | A trie of words with character type @a@ and entry type @b@.+-- It represents a 'M.Map' from @[a]@ keys to @b@ values.+data Trie a b = Trie {+    -- | Value in the root node.+    rootValue   :: b,                  +    -- | Edges to subtries annotated with characters.+    edgeMap     :: M.Map a (Trie a b)+    } deriving (Show, Eq, Ord)++instance Functor (Trie a) where+    fmap f Trie{..} = Trie (f rootValue) (fmap (fmap f) edgeMap)++instance (Ord a, Binary a, Binary b) => Binary (Trie a b) where+    put Trie{..} = do+        put rootValue+        put edgeMap+    get = Trie <$> get <*> get++-- | Decompose the trie into a pair of root value and edge list.+unTrie :: Trie a b -> (b, [(a, Trie a b)])+unTrie t = (rootValue t, M.toList $ edgeMap t)+{-# INLINE unTrie #-}++-- | Child of the trie following the edge annotated with the given character.+child :: Ord a => a -> Trie a b -> Maybe (Trie a b)+child x Trie{..} = x `M.lookup` edgeMap+{-# INLINE child #-}++-- | Return trie edges as a list of (annotation character, subtrie) pairs.+anyChild :: Trie a b -> [(a, Trie a b)]+anyChild = snd . unTrie+{-# INLINE anyChild #-}++-- | Construct trie from the root value and the list of edges.+mkTrie :: Ord a => b -> [(a, Trie a b)] -> Trie a b+mkTrie !v !cs = Trie v (M.fromList cs)+{-# INLINE mkTrie #-}++-- | Empty trie.+empty :: Ord a => TrieM a b+empty = mkTrie Nothing []+{-# INLINE empty #-}++-- | Set the value in the root of the trie.+setValue :: b -> Trie a b -> Trie a b+setValue !x !t = t { rootValue = x }+{-# INLINE setValue #-}++-- | Substitute subtrie attached to the edge annotated with the given+-- character (or add new edge if such edge did not exist).+substChild :: Ord a => a -> Trie a b -> Trie a b -> Trie a b+substChild !x !trie !newChild =+    let how _ = Just newChild+        !edges = M.alter how x (edgeMap trie)+    in trie { edgeMap = edges }+{-# INLINABLE substChild #-}+{-# SPECIALIZE substChild+    :: Char+    -> Trie Char b+    -> Trie Char b+    -> Trie Char b #-}++-- | Insert word with the given value to the trie.+insert :: Ord a => [a] -> b -> TrieM a b -> TrieM a b+insert [] v t = setValue (Just v) t+insert (x:xs) v t = substChild x t . insert xs v $+    case child x t of+        Just t' -> t'+        Nothing -> empty+{-# INLINABLE insert #-}+{-# SPECIALIZE insert+    :: String -> b+    -> TrieM Char b+    -> TrieM Char b #-}++-- | Size of the trie.+size :: Trie a b -> Int+size t = 1 + sum (map (size.snd) (anyChild t))++-- | Follow the path determined by the input word starting+-- in the trie root.+follow :: Ord a => [a] -> Trie a b -> Maybe (Trie a b)+follow xs t = foldr (>=>) return (map child xs) t++-- | Search for the value assigned to the given word in the trie.+lookup :: Ord a => [a] -> TrieM a b -> Maybe b+lookup xs t = follow xs t >>= rootValue++-- | Construct the trie from the list of (word, value) pairs.+fromList :: Ord a => [([a], b)] -> TrieM a b+fromList xs =+    let update t (x, v) = insert x v t+    in  foldl' update empty xs++-- | Deconstruct the trie into a list of (word, value) pairs.+toList :: TrieM a b -> [([a], b)]+toList t = case rootValue t of+    Just y -> ([], y) : lower+    Nothing -> lower+  where+    lower = concatMap goDown $ anyChild t+    goDown (x, t') = map (addChar x) $ toList t'+    addChar x (xs, y) = (x:xs, y)++-- | Make the trie from the list of words.  Annotate each word with+-- the @()@ value.+fromLang :: Ord a => [[a]] -> TrieM a ()+fromLang xs = fromList [(x, ()) | x <- xs]++-- | Elminate common subtries.  The result is algebraically a trie+-- but is represented as a DAWG in memory.+implicitDAWG :: (Ord a, Ord b) => Trie a b -> Trie a b+implicitDAWG = deserialize . serialize++-- | Serialize the trie and eliminate all common subtries+-- along the way.+serialize :: (Ord a, Ord b) => Trie a b -> [Node a b]+serialize r =+    [ mkNode (rootValue t)+        [ (c, m M.! s)+        | (c, s) <- anyChild t ]+    | t <- M.elems m' ]+  where+    m  = collect r+    m' = M.fromList [(y, x) | (x, y) <- M.toList m]++-- | Construct the trie from the node list.+deserialize :: Ord a => [Node a b] -> Trie a b+deserialize =+    snd . M.findMax . foldl' update M.empty+  where+    update m n =+        let t = mkTrie (nodeValue n) [(c, m M.! k) | (c, k) <- nodeEdges n]+        in  M.insert (M.size m) t m++-- | Collect unique tries and assign identifiers to them.+collect :: (Ord a, Ord b) => Trie a b -> M.Map (Trie a b) Int+collect t = collect' M.empty t++collect' :: (Ord a, Ord b) => M.Map (Trie a b) Int+         -> Trie a b -> M.Map (Trie a b) Int+collect' m0 t = M.alter f t m+  where+    !m = foldl' collect' m0 (M.elems $ edgeMap t)+    !k = M.size m+    f Nothing  = Just k+    f (Just x) = Just x

@@ -1,5 +1,5 @@ name:               adict-version:            0.2.0+version:            0.3.0 synopsis:           Approximate dictionary searching description:     Approximate dictionary searching library.@@ -25,18 +25,20 @@      exposed-modules:         NLP.Adict-      , NLP.Adict.Core       , NLP.Adict.CostDiv-      , NLP.Adict.Dist-      , NLP.Adict.Brute       , NLP.Adict.Trie       , NLP.Adict.DAWG-      , NLP.Adict.Basic      other-modules:-        NLP.Adict.Graph-      , NLP.Adict.DAWG.Node+        NLP.Adict.Core+      , NLP.Adict.Dist+      , NLP.Adict.Brute+      , NLP.Adict.Basic+      , NLP.Adict.Graph       , NLP.Adict.Nearest+      , NLP.Adict.Node+      , NLP.Adict.Trie.Internal+      , NLP.Adict.DAWG.Internal      ghc-options: -Wall -O2 

@@ -12,11 +12,8 @@ import Test.Framework (Test, defaultMain) import Test.Framework.Providers.QuickCheck2 (testProperty) -import NLP.Adict.Core+import NLP.Adict import qualified NLP.Adict.CostDiv as C-import qualified NLP.Adict.Brute as Br-import qualified NLP.Adict.Basic as Ba-import qualified NLP.Adict.Nearest as Nr import qualified NLP.Adict.Trie as Trie import qualified NLP.Adict.DAWG as DAWG @@ -137,8 +134,8 @@ -- be the same no matter which searching function is used. pBaseEqBrute :: CostDesc -> Positive Double -> String -> Lang -> Bool pBaseEqBrute costDesc kP xR lang =-    let br = (nub . map unWord) (Br.search cost k x ys)-        ba = nub (Ba.search cost k x trie)+    let br = (nub . map unWord) (bruteSearch cost k x ys)+        ba = nub (findAll cost k x trie)     in  br == ba   where     x = V.fromList xR@@ -150,8 +147,8 @@  pBaseEqNearest :: CostDivDesc -> Positive Double -> String -> Lang -> Bool pBaseEqNearest costDesc kP xR lang =-    let ba = Ba.search cost k x trie-        nr = Nr.search costDiv k x dawg+    let ba = findAll cost k x trie+        nr = findNearest costDiv k x dawg     in  check ba nr   where     check [] (Just _) = False@@ -169,7 +166,7 @@     cost = C.toCostInf costDiv      trie = Trie.fromLang (getWords lang)-    dawg = DAWG.deserialize . Trie.serialize $ trie+    dawg = DAWG.fromTrie trie  nub :: Ord a => [a] -> [a] nub = S.toList . S.fromList