adict 0.3.0 → 0.4.0
raw patch · 23 files changed
+554/−932 lines, 23 filesdep +dawgPVP ok
version bump matches the API change (PVP)
Dependencies added: dawg
API changes (from Hackage documentation)
- NLP.Adict: DAWG :: Int -> Vector (Node a b) -> DAWG a b
- NLP.Adict: Node :: b -> Vector (a, Int) -> Node a b
- NLP.Adict: Trie :: b -> Map a (Trie a b) -> Trie a b
- NLP.Adict: data DAWG a b
- NLP.Adict: data Node a b
- NLP.Adict: data Trie a b
- NLP.Adict: edgeMap :: Trie a b -> Map a (Trie a b)
- NLP.Adict: fromDAWG :: Ord a => DAWG a b -> Trie a b
- NLP.Adict: fromList :: Ord a => [([a], b)] -> TrieM a b
- NLP.Adict: fromTrie :: (Ord a, Ord b) => Trie a b -> DAWG a b
- NLP.Adict: implicitDAWG :: (Ord a, Ord b) => Trie a b -> Trie a b
- NLP.Adict: nodes :: DAWG a b -> Vector (Node a b)
- NLP.Adict: root :: DAWG a b -> Int
- NLP.Adict: rootValue :: Trie a b -> b
- NLP.Adict: subNodes :: Node a b -> Vector (a, Int)
- NLP.Adict: type DAWGM a b = DAWG a (Maybe b)
- NLP.Adict: type TrieM a b = Trie a (Maybe b)
- NLP.Adict: valueIn :: Node a b -> b
- NLP.Adict.DAWG: DAWG :: Int -> Vector (Node a b) -> DAWG a b
- NLP.Adict.DAWG: Node :: b -> Vector (a, Int) -> Node a b
- NLP.Adict.DAWG: data DAWG a b
- NLP.Adict.DAWG: data Node a b
- NLP.Adict.DAWG: fromDAWG :: Ord a => DAWG a b -> Trie a b
- NLP.Adict.DAWG: fromTrie :: (Ord a, Ord b) => Trie a b -> DAWG a b
- NLP.Adict.DAWG: nodes :: DAWG a b -> Vector (Node a b)
- NLP.Adict.DAWG: root :: DAWG a b -> Int
- NLP.Adict.DAWG: subNodes :: Node a b -> Vector (a, Int)
- NLP.Adict.DAWG: type DAWGM a b = DAWG a (Maybe b)
- NLP.Adict.DAWG: valueIn :: Node a b -> b
- NLP.Adict.Trie: Trie :: b -> Map a (Trie a b) -> Trie a b
- NLP.Adict.Trie: data Trie a b
- NLP.Adict.Trie: edgeMap :: Trie a b -> Map a (Trie a b)
- NLP.Adict.Trie: empty :: Ord a => TrieM a b
- NLP.Adict.Trie: follow :: Ord a => [a] -> Trie a b -> Maybe (Trie a b)
- NLP.Adict.Trie: fromLang :: Ord a => [[a]] -> TrieM a ()
- NLP.Adict.Trie: fromList :: Ord a => [([a], b)] -> TrieM a b
- NLP.Adict.Trie: implicitDAWG :: (Ord a, Ord b) => Trie a b -> Trie a b
- NLP.Adict.Trie: insert :: Ord a => [a] -> b -> TrieM a b -> TrieM a b
- NLP.Adict.Trie: lookup :: Ord a => [a] -> TrieM a b -> Maybe b
- NLP.Adict.Trie: rootValue :: Trie a b -> b
- NLP.Adict.Trie: toList :: TrieM a b -> [([a], b)]
- NLP.Adict.Trie: type TrieM a b = Trie a (Maybe b)
+ NLP.Adict.Dist: editDist :: Cost a -> Word a -> Word a -> Weight
- NLP.Adict: findAll :: Cost a -> Double -> Word a -> TrieM a b -> [([a], b, Double)]
+ NLP.Adict: findAll :: (Enum a, Unbox w) => Cost a -> Double -> Word a -> DAWG a w b -> [([a], b, Double)]
- NLP.Adict: findNearest :: CostDiv a -> Double -> Word a -> DAWGM a b -> Maybe ([a], b, Double)
+ NLP.Adict: findNearest :: (Enum a, Unbox w) => CostDiv a -> Double -> Word a -> DAWG a w b -> Maybe ([a], b, Double)
Files
- NLP/Adict.hs +0/−89
- NLP/Adict/Basic.hs +0/−61
- NLP/Adict/Brute.hs +0/−21
- NLP/Adict/Core.hs +0/−47
- NLP/Adict/CostDiv.hs +0/−130
- NLP/Adict/DAWG.hs +0/−13
- NLP/Adict/DAWG/Internal.hs +0/−122
- NLP/Adict/Dist.hs +0/−29
- NLP/Adict/Graph.hs +0/−88
- NLP/Adict/Nearest.hs +0/−86
- NLP/Adict/Node.hs +0/−24
- NLP/Adict/Trie.hs +0/−17
- NLP/Adict/Trie/Internal.hs +0/−188
- adict.cabal +9/−10
- src/NLP/Adict.hs +51/−0
- src/NLP/Adict/Basic.hs +75/−0
- src/NLP/Adict/Brute.hs +21/−0
- src/NLP/Adict/Core.hs +47/−0
- src/NLP/Adict/CostDiv.hs +130/−0
- src/NLP/Adict/Dist.hs +29/−0
- src/NLP/Adict/Graph.hs +88/−0
- src/NLP/Adict/Nearest.hs +99/−0
- tests/Properties.hs +5/−7
− NLP/Adict.hs
@@ -1,89 +0,0 @@--- | This module re-exports main data types and functions from the adict library.--module NLP.Adict-(--- * Dictionary representation--- $data-structures---- ** Trie- Trie (..)-, TrieM-, fromList-, implicitDAWG---- ** Directed acyclic word graph-, DAWG (..)-, Node (..)-, DAWGM-, fromTrie-, fromDAWG---- * Approximate searching --- $searching---- ** Cost function -, Word-, Pos-, Weight-, Cost (..)-, costDefault---- ** Searching methods-, bruteSearch-, findAll-, findNearest-) where--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-- The library provides two basic data structures used for dictionary- representation. The first one is a 'Trie', which can be constructed - from a list of dictionary entries by using the 'fromList' function.-- The trie can be translated into a directed acyclic word graph ('DAWG')- using the 'fromTrie' function (for the moment it is done in an- inefficient manner, though). -- There is also a possibility of constructing an implicit DAWG, i.e. a DAWG- which is algebraically represented by a trie with sharing of common subtries,- by using the 'implicitDAWG' function (which is also inefficient right now;- in fact, the 'fromTrie' function uses this one underneath).-- Finally, the DAWG can be transformed back to a trie (implicit DAWG) using- the 'fromDAWG' function.---}--{- $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.--}
− NLP/Adict/Basic.hs
@@ -1,61 +0,0 @@-module NLP.Adict.Basic-( findAll-) where--import Data.Ix (range)-import qualified Data.Array as A-import qualified Data.Vector as V--import NLP.Adict.Core-import NLP.Adict.Trie.Internal hiding (insert)---- | Find all words within a trie with restricted generalized edit distance--- lower or equall to k.-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 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-- dist' = (A.!) distV - distV = A.array bounds [(i, dist i) | i <- range bounds]- bounds = (0, m)- m = V.length x-- dist 0 = 0- dist i = dist' (i-1) + (delete cost) i (x#i)--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 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- appendChar (cs, y, w) = ((c:cs), y, w)-- dist' = (A.!) distV - distV = A.array bounds [(i, dist i) | i <- range bounds]- bounds = (0, m)- m = V.length x-- dist 0 = distP 0 + (insert cost) 0 c- dist i = minimum- [ distP (i-1) + (subst cost) i (x#i) c- , dist' (i-1) + (delete cost) i (x#i) - , distP i + (insert cost) i c ]
− NLP/Adict/Brute.hs
@@ -1,21 +0,0 @@-module NLP.Adict.Brute-( bruteSearch-) where--import Data.Maybe (mapMaybe)--import NLP.Adict.Core-import NLP.Adict.Dist---- | Find all words within a list with restricted generalized edit distance--- from x lower or equall to k.-bruteSearch :: Cost a -> Double -> Word a- -> [(Word a, b)] -> [(Word a, b, Double)]-bruteSearch cost k x =- mapMaybe check- where- check (y, v)- | dist <= k = Just (y, v, dist)- | otherwise = Nothing- where- dist = editDist cost x y
− NLP/Adict/Core.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--module NLP.Adict.Core-( Word-, Pos-, Weight-, costDefault-, Cost (..)-, (#)-) where--import qualified Data.Vector as V--(#) :: V.Vector a -> Int -> a-x#i = x V.! (i-1)-{-# INLINE (#) #-}---- | A word parametrized with character type 'a'.-type Word a = V.Vector a---- | Position in a sentence.-type Pos = Int---- | Cost of edit operation. It has to be a non-negative value!-type Weight = Double---- | Cost represents a cost (or weight) of a symbol insertion, deletion or--- substitution. It can depend on edit operation position and on symbol--- values.-data Cost a = Cost- { insert :: Pos -> a -> Weight- , delete :: Pos -> a -> Weight- , subst :: Pos -> a -> a -> Weight }---- | Simple cost function: all edit operations cost 1 unit.-costDefault :: Eq a => Cost a-costDefault =- Cost _insert _delete _subst- where- _insert _ _ = 1- _delete _ _ = 1- _subst _ x y- | x == y = 0- | otherwise = 1-{-# INLINABLE costDefault #-}-{-# SPECIALIZE costDefault :: Cost Char #-}
− NLP/Adict/CostDiv.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | Alternative cost representation with individual cost components--- divided into groups with respect to operation weights. --module NLP.Adict.CostDiv-(--- * CostDiv- Group (..)-, CostDiv (..)-, costDefault---- * Helper functions for CostDiv construction -, Sub-, mkSub-, unSub-, SubMap-, subOn-, mkSubMap---- * Conversion to standard representation-, toCost-, toCostInf-) where--import qualified Data.Set as S-import qualified Data.Map as M--import NLP.Adict.Core (Pos, Cost(..), Weight)----- 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 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- where- insert = [Filter (const True) 1]- delete _ = 1- subst x =- [ Filter eq 0- , Filter ot 1 ]- where- eq = (x==)- ot = not.eq- posMod = const 1-{-# INLINABLE costDefault #-}-{-# SPECIALIZE costDefault :: CostDiv Char #-}---- | 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 ]---- | 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 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- where- del k x = delete x * posMod k- ins k x = mini [w | Filter f w <- insert, f x] * posMod k- sub k x y = mini [w | Filter f w <- subst x, f y] * posMod k- mini [] = defa- mini xs = minimum xs---- | Transform CostDiv to plain Cost function with default weight value--- set to @+Infinity@.-toCostInf :: CostDiv a -> Cost a-toCostInf =- let inf = 1 / 0- in toCost inf
− NLP/Adict/DAWG.hs
@@ -1,13 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | A directed acyclic word graph.--module NLP.Adict.DAWG-( DAWG (..)-, Node (..)-, DAWGM-, fromTrie-, fromDAWG-) where--import NLP.Adict.DAWG.Internal
− NLP/Adict/DAWG/Internal.hs
@@ -1,122 +0,0 @@-{-# 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
− NLP/Adict/Dist.hs
@@ -1,29 +0,0 @@-module NLP.Adict.Dist-( editDist-) where--import qualified Data.Array as A-import qualified Data.Vector as V-import Data.Ix (range)--import NLP.Adict.Core---- | Restricted generalized edit distance between two words with--- given cost function.-editDist :: Cost a -> Word a -> Word a -> Weight-editDist cost x y =- dist' m n- where- dist' i j = distA A.! (i, j)- distA = A.array bounds [(k, uncurry dist k) | k <- range bounds]- bounds = ((0, 0), (m, n))- m = V.length x- n = V.length y-- dist 0 0 = 0- dist i 0 = dist' (i-1) 0 + (delete cost) i (x#i)- dist 0 j = dist' 0 (j-1) + (insert cost) 0 (y#j)- dist i j = minimum- [ dist' (i-1) (j-1) + (subst cost) i (x#i) (y#j)- , dist' (i-1) j + (delete cost) i (x#i) - , dist' i (j-1) + (insert cost) i (y#j) ]
− NLP/Adict/Graph.hs
@@ -1,88 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeSynonymInstances #-}--module NLP.Adict.Graph-( minPath-, Edges-, IsEnd-) where--import qualified Data.PSQueue as P-import qualified Data.Map as M---- | 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?-type IsEnd n = n -> Bool---- | Non-empty list of adjacent nodes given in an ascending order.-data Adj n w = Adj- { from :: n- , to :: [(w, n)] }- deriving (Show, Eq, Ord)---- | First element from the the adjacent list, which is also--- a priority in the priority queue.-proxy :: Adj n w -> (w, n)-proxy = head . to-{-# INLINE proxy #-}---- | Tail elements from the adjacent list.-folls :: Adj n w -> [(w, n)]-folls = tail . to-{-# INLINE folls #-}---- | Priority queue.-type PQ n w = P.PSQ (Adj n w) (w, n)---- | Remove minimal edge (from, weight, to) from the queue.-minView :: (Ord n, Ord w) => PQ n w -> Maybe (Edge n w, PQ n w)-minView queue = do- (adj P.:-> (w, q), queue') <- P.minView queue- let p = from adj- e = (p, w, q)- return (e, push queue' p (folls adj))--push :: (Ord n, Ord w) => PQ n w -> n -> [(w, n)] -> PQ n w-push queue _ [] = queue-push queue p xs = insert (Adj p xs) queue-{-# INLINE push #-}--insert :: (Ord n, Ord w) => Adj n w -> PQ n w -> PQ n w-insert x = P.insert x (proxy x)-{-# INLINE insert #-}---- | Find the shortest path from the beginning node to one--- of the ending nodes.-minPath :: (Ord n, Ord w, Num w, Fractional w)- => w -> Edges n w -> IsEnd n -> n -> Maybe ([n], w)-minPath threshold edgesFrom isEnd beg =-- shortest M.empty $ insert (Adj beg [(0, beg)]) P.empty-- where-- -- @visited@: set of visited nodes- -- @queue@: priority queue- shortest visited queue = do- (edge, queue') <- minView queue- shortest' visited queue' edge-- shortest' visited queue (p, w, q)- | isEnd q = Just (reverse (trace visited' q), w)- | q `M.member` visited = shortest visited queue- | otherwise = shortest visited' queue'- where- visited' = M.insert q p visited- queue' = push queue q $- takeWhile ((<= threshold) . fst)- [(w + u, s) | (u, s) <- edgesFrom q]-- trace visited n- | m == n = [n]- | otherwise = n : trace visited m- where- m = visited M.! n
− NLP/Adict/Nearest.hs
@@ -1,86 +0,0 @@-module NLP.Adict.Nearest-( findNearest-) where--import Control.Applicative ((<$>))-import Control.Monad (guard)-import Data.Maybe (isJust, catMaybes)-import Data.List (sortBy)-import Data.Ord (comparing)-import Data.Function (on)-import qualified Data.Vector as V--import NLP.Adict.Core (Pos, Weight, Word, (#))-import NLP.Adict.CostDiv-import NLP.Adict.DAWG.Internal hiding (Node)-import NLP.Adict.Graph--type NodeID = Int-data Node a = Node- { nodeID :: {-# UNPACK #-} !NodeID- , nodePos :: {-# UNPACK #-} !Pos- , nodeChar :: !(Maybe a) }- deriving (Show)--proxy :: Node a -> (NodeID, Pos)-proxy n = (nodeID n, nodePos n)-{-# INLINE proxy #-}--instance Eq (Node a) where- (==) = (==) `on` proxy--instance Ord (Node a) where- compare = compare `on` proxy--data Which a- = Del Weight- | Ins (Group a)- | Sub (Group a)--weightOf :: Which a -> Weight-weightOf (Del w) = w-weightOf (Ins g) = weight g-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.-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 <- valueBy dag $ nodeID $ last xs- return (form, r, w)- where- edgesFrom (Node n i _) =- concatMap follow $ sortBy (comparing weightOf) groups- where- j = i+1-- groups = insGroups ++ delGroups ++ subGroups- insGroups = Ins . mapWeight (*posMod cost i) <$>- insert cost- delGroups = Del . (*posMod cost j) <$> do- guard (j <= V.length x)- return $ delete cost (x#j)- subGroups = Sub . mapWeight (*posMod cost j) <$> do- guard (j <= V.length x)- subst cost (x#j)-- follow (Ins (Filter f w)) =- [ (w, Node m i (Just c))- | (c, m) <- edges dag n- , f c ]-- follow (Del w) = [(w, Node n j Nothing)]-- follow (Sub (Filter f w)) =- [ (w, Node m j (Just c))- | (c, m) <- edges dag n- , f c ]-- isEnd (Node n k _) = k == V.length x && isJust (valueBy dag n)
− NLP/Adict/Node.hs
@@ -1,24 +0,0 @@-{-# 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
− NLP/Adict/Trie.hs
@@ -1,17 +0,0 @@--- | A (prefix) trie.--module NLP.Adict.Trie-( Trie (..)-, TrieM-, empty-, insert-, fromList-, toList-, follow-, lookup-, fromLang-, implicitDAWG-) where--import Prelude hiding (lookup)-import NLP.Adict.Trie.Internal
− NLP/Adict/Trie/Internal.hs
@@ -1,188 +0,0 @@-{-# 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
adict.cabal view
@@ -1,5 +1,5 @@ name: adict-version: 0.3.0+version: 0.4.0 synopsis: Approximate dictionary searching description: Approximate dictionary searching library.@@ -15,30 +15,28 @@ build-type: Simple library+ hs-source-dirs: src+ build-depends:- base >= 4 && <= 5+ base >= 4 && <= 5 , containers , vector , array- , PSQueue >= 1.1 && < 1.2+ , PSQueue >= 1.1 && < 1.2 , binary+ , dawg >= 0.11 && < 0.12 exposed-modules: NLP.Adict , NLP.Adict.CostDiv- , NLP.Adict.Trie- , NLP.Adict.DAWG+ , NLP.Adict.Dist other-modules: NLP.Adict.Core- , NLP.Adict.Dist+ , NLP.Adict.Graph , 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 @@ -53,6 +51,7 @@ , vector , test-framework >= 0.3.3 , test-framework-quickcheck2 >= 0.2.9+ , dawg >= 0.11 && < 0.12 , adict ghc-options: -Wall
+ src/NLP/Adict.hs view
@@ -0,0 +1,51 @@+-- | This module re-exports main data types and functions from the adict library.++module NLP.Adict+(+-- * Approximate searching +-- $searching++-- ** Cost function + Word+, Pos+, Weight+, Cost (..)+, costDefault++-- ** Searching methods+, bruteSearch+, findAll+, findNearest+) where++import NLP.Adict.Core (Word, Pos, Weight, costDefault, Cost (..))+import NLP.Adict.Brute (bruteSearch)+import NLP.Adict.Basic (findAll)+import NLP.Adict.Nearest (findNearest)++{- $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.+-}
+ src/NLP/Adict/Basic.hs view
@@ -0,0 +1,75 @@+module NLP.Adict.Basic+( findAll+) where++import Data.Ix (range)+import qualified Data.Array as A+import qualified Data.Vector as V+import Data.Vector.Unboxed (Unbox)++import NLP.Adict.Core+import Data.DAWG.Static (DAWG)+import qualified Data.DAWG.Static as D++-- | Find all words within a DAWG with restricted generalized edit distance+-- lower than or equal to a given threshold.+findAll+ :: (Enum a, Unbox w) + => Cost a -- ^ Cost function+ -> Double -- ^ Threshold+ -> Word a -- ^ Query word+ -> DAWG a w b+ -> [([a], b, Double)]+findAll cost k x dawg =+ foundHere ++ foundLower+ where+ foundHere+ | dist' m <= k = case D.lookup [] dawg of+ Just y -> [([], y, dist' m)]+ Nothing -> []+ | otherwise = []+ foundLower+ | minimum (A.elems distV) > k = []+ | otherwise = concatMap searchLower $ D.edges dawg+ searchLower = search cost k dist' x++ dist' = (A.!) distV + distV = A.array bounds [(i, dist i) | i <- range bounds]+ bounds = (0, m)+ m = V.length x++ dist 0 = 0+ dist i = dist' (i-1) + (delete cost) i (x#i)++search+ :: (Enum a, Unbox w)+ => Cost a -- ^ Cost function+ -> Double -- ^ Threshold+ -> (Int -> Double) -- ^ ???+ -> Word a -- ^ Query word+ -> (a, DAWG a w b) -- ^ DAWG edge considered+ -> [([a], b, Double)]+search cost k distP x (c, dawg) =+ foundHere ++ map appendChar foundLower+ where+ foundHere+ | dist' m <= k = case D.lookup [] dawg of+ Just y -> [([c], y, dist' m)]+ Nothing -> []+ | otherwise = []+ foundLower+ | minimum (A.elems distV) > k = []+ | otherwise = concatMap searchLower $ D.edges dawg+ searchLower = search cost k dist' x+ appendChar (cs, y, w) = ((c:cs), y, w)++ dist' = (A.!) distV + distV = A.array bounds [(i, dist i) | i <- range bounds]+ bounds = (0, m)+ m = V.length x++ dist 0 = distP 0 + (insert cost) 0 c+ dist i = minimum+ [ distP (i-1) + (subst cost) i (x#i) c+ , dist' (i-1) + (delete cost) i (x#i) + , distP i + (insert cost) i c ]
+ src/NLP/Adict/Brute.hs view
@@ -0,0 +1,21 @@+module NLP.Adict.Brute+( bruteSearch+) where++import Data.Maybe (mapMaybe)++import NLP.Adict.Core+import NLP.Adict.Dist++-- | Find all words within a list with restricted generalized edit distance+-- from x lower or equall to k.+bruteSearch :: Cost a -> Double -> Word a+ -> [(Word a, b)] -> [(Word a, b, Double)]+bruteSearch cost k x =+ mapMaybe check+ where+ check (y, v)+ | dist <= k = Just (y, v, dist)+ | otherwise = Nothing+ where+ dist = editDist cost x y
+ src/NLP/Adict/Core.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module NLP.Adict.Core+( Word+, Pos+, Weight+, costDefault+, Cost (..)+, (#)+) where++import qualified Data.Vector as V++(#) :: V.Vector a -> Int -> a+x#i = x V.! (i-1)+{-# INLINE (#) #-}++-- | A word parametrized with character type 'a'.+type Word a = V.Vector a++-- | Position in a sentence.+type Pos = Int++-- | Cost of edit operation. It has to be a non-negative value!+type Weight = Double++-- | Cost represents a cost (or weight) of a symbol insertion, deletion or+-- substitution. It can depend on edit operation position and on symbol+-- values.+data Cost a = Cost+ { insert :: Pos -> a -> Weight+ , delete :: Pos -> a -> Weight+ , subst :: Pos -> a -> a -> Weight }++-- | Simple cost function: all edit operations cost 1 unit.+costDefault :: Eq a => Cost a+costDefault =+ Cost _insert _delete _subst+ where+ _insert _ _ = 1+ _delete _ _ = 1+ _subst _ x y+ | x == y = 0+ | otherwise = 1+{-# INLINABLE costDefault #-}+{-# SPECIALIZE costDefault :: Cost Char #-}
+ src/NLP/Adict/CostDiv.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE RecordWildCards #-}++-- | Alternative cost representation with individual cost components+-- divided into groups with respect to operation weights. ++module NLP.Adict.CostDiv+(+-- * CostDiv+ Group (..)+, CostDiv (..)+, costDefault++-- * Helper functions for CostDiv construction +, Sub+, mkSub+, unSub+, SubMap+, subOn+, mkSubMap++-- * Conversion to standard representation+, toCost+, toCostInf+) where++import qualified Data.Set as S+import qualified Data.Map as M++import NLP.Adict.Core (Pos, Cost(..), Weight)+++-- 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 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+ where+ insert = [Filter (const True) 1]+ delete _ = 1+ subst x =+ [ Filter eq 0+ , Filter ot 1 ]+ where+ eq = (x==)+ ot = not.eq+ posMod = const 1+{-# INLINABLE costDefault #-}+{-# SPECIALIZE costDefault :: CostDiv Char #-}++-- | 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 ]++-- | 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 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+ where+ del k x = delete x * posMod k+ ins k x = mini [w | Filter f w <- insert, f x] * posMod k+ sub k x y = mini [w | Filter f w <- subst x, f y] * posMod k+ mini [] = defa+ mini xs = minimum xs++-- | Transform CostDiv to plain Cost function with default weight value+-- set to @+Infinity@.+toCostInf :: CostDiv a -> Cost a+toCostInf =+ let inf = 1 / 0+ in toCost inf
+ src/NLP/Adict/Dist.hs view
@@ -0,0 +1,29 @@+module NLP.Adict.Dist+( editDist+) where++import qualified Data.Array as A+import qualified Data.Vector as V+import Data.Ix (range)++import NLP.Adict.Core++-- | Restricted generalized edit distance between two words with+-- given cost function.+editDist :: Cost a -> Word a -> Word a -> Weight+editDist cost x y =+ dist' m n+ where+ dist' i j = distA A.! (i, j)+ distA = A.array bounds [(k, uncurry dist k) | k <- range bounds]+ bounds = ((0, 0), (m, n))+ m = V.length x+ n = V.length y++ dist 0 0 = 0+ dist i 0 = dist' (i-1) 0 + (delete cost) i (x#i)+ dist 0 j = dist' 0 (j-1) + (insert cost) 0 (y#j)+ dist i j = minimum+ [ dist' (i-1) (j-1) + (subst cost) i (x#i) (y#j)+ , dist' (i-1) j + (delete cost) i (x#i) + , dist' i (j-1) + (insert cost) i (y#j) ]
+ src/NLP/Adict/Graph.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeSynonymInstances #-}++module NLP.Adict.Graph+( minPath+, Edges+, IsEnd+) where++import qualified Data.PSQueue as P+import qualified Data.Map as M++-- | 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?+type IsEnd n = n -> Bool++-- | Non-empty list of adjacent nodes given in an ascending order.+data Adj n w = Adj+ { from :: n+ , to :: [(w, n)] }+ deriving (Show, Eq, Ord)++-- | First element from the the adjacent list, which is also+-- a priority in the priority queue.+proxy :: Adj n w -> (w, n)+proxy = head . to+{-# INLINE proxy #-}++-- | Tail elements from the adjacent list.+folls :: Adj n w -> [(w, n)]+folls = tail . to+{-# INLINE folls #-}++-- | Priority queue.+type PQ n w = P.PSQ (Adj n w) (w, n)++-- | Remove minimal edge (from, weight, to) from the queue.+minView :: (Ord n, Ord w) => PQ n w -> Maybe (Edge n w, PQ n w)+minView queue = do+ (adj P.:-> (w, q), queue') <- P.minView queue+ let p = from adj+ e = (p, w, q)+ return (e, push queue' p (folls adj))++push :: (Ord n, Ord w) => PQ n w -> n -> [(w, n)] -> PQ n w+push queue _ [] = queue+push queue p xs = insert (Adj p xs) queue+{-# INLINE push #-}++insert :: (Ord n, Ord w) => Adj n w -> PQ n w -> PQ n w+insert x = P.insert x (proxy x)+{-# INLINE insert #-}++-- | Find the shortest path from the beginning node to one+-- of the ending nodes.+minPath :: (Ord n, Ord w, Num w, Fractional w)+ => w -> Edges n w -> IsEnd n -> n -> Maybe ([n], w)+minPath threshold edgesFrom isEnd beg =++ shortest M.empty $ insert (Adj beg [(0, beg)]) P.empty++ where++ -- @visited@: set of visited nodes+ -- @queue@: priority queue+ shortest visited queue = do+ (edge, queue') <- minView queue+ shortest' visited queue' edge++ shortest' visited queue (p, w, q)+ | isEnd q = Just (reverse (trace visited' q), w)+ | q `M.member` visited = shortest visited queue+ | otherwise = shortest visited' queue'+ where+ visited' = M.insert q p visited+ queue' = push queue q $+ takeWhile ((<= threshold) . fst)+ [(w + u, s) | (u, s) <- edgesFrom q]++ trace visited n+ | m == n = [n]+ | otherwise = n : trace visited m+ where+ m = visited M.! n
+ src/NLP/Adict/Nearest.hs view
@@ -0,0 +1,99 @@+module NLP.Adict.Nearest+( findNearest+) where++import Control.Applicative ((<$>))+import Control.Monad (guard)+import Data.Maybe (isJust, catMaybes, maybeToList)+import Data.List (sortBy)+import Data.Ord (comparing)+import Data.Function (on)+import qualified Data.Vector as V+import Data.Vector.Unboxed (Unbox)++import NLP.Adict.Core (Pos, Weight, Word, (#))+import NLP.Adict.CostDiv+import NLP.Adict.Graph+import qualified Data.DAWG.Static as D+import Data.DAWG.Static (DAWG, ID)++data Node a = Node+ { nodeID :: {-# UNPACK #-} !ID+ , nodePos :: {-# UNPACK #-} !Pos+ , nodeChar :: !(Maybe a) }+ deriving (Show)++proxy :: Node a -> (ID, Pos)+proxy n = (nodeID n, nodePos n)+{-# INLINE proxy #-}++instance Eq (Node a) where+ (==) = (==) `on` proxy++instance Ord (Node a) where+ compare = compare `on` proxy++data Which a+ = Del Weight+ | Ins (Group a)+ | Sub (Group a)++weightOf :: Which a -> Weight+weightOf (Del w) = w+weightOf (Ins g) = weight g+weightOf (Sub g) = weight g+{-# INLINE weightOf #-}++mapWeight :: (Weight -> Weight) -> Group a -> Group a+mapWeight f g = g { weight = f (weight g) }++-- | We could check, if CostDiv satisfies basic properties. On the other+-- hand, we do not do this for plain Cost function.+findNearest+ :: (Enum a, Unbox w)+ => CostDiv a -- ^ Cost function+ -> Double -- ^ Threshold+ -> Word a -- ^ Query word+ -> DAWG a w b+ -> Maybe ([a], b, Double)+findNearest cost z x dag = do+ (xs, w) <- minPath z edgesFrom isEnd (Node (D.rootID dag) 0 Nothing)+ let form = catMaybes . map nodeChar $ xs+ -- TODO: is the assumption, that (length xs > 0), satisfied?+ r <- valueBy dag $ nodeID $ last xs+ return (form, r, w)+ where+ edgesFrom (Node ni i _) =+ concatMap follow $ sortBy (comparing weightOf) groups+ where+ j = i+1++ groups = insGroups ++ delGroups ++ subGroups+ insGroups = Ins . mapWeight (*posMod cost i) <$>+ insert cost+ delGroups = Del . (*posMod cost j) <$> do+ guard (j <= V.length x)+ return $ delete cost (x#j)+ subGroups = Sub . mapWeight (*posMod cost j) <$> do+ guard (j <= V.length x)+ subst cost (x#j)++ follow (Ins (Filter f w)) =+ [ (w, Node (D.rootID m) i (Just c))+ | dawg' <- maybeToList (D.byID ni dag)+ , (c, m) <- D.edges dawg', f c ]++ follow (Del w) = [(w, Node ni j Nothing)]++ follow (Sub (Filter f w)) =+ [ (w, Node (D.rootID m) j (Just c))+ | dawg' <- maybeToList (D.byID ni dag)+ , (c, m) <- D.edges dawg', f c ]++ isEnd (Node ni k _) = k == V.length x && isJust (valueBy dag ni)++-- | Get value of a node at the given ID.+valueBy :: (Enum a, Unbox w) => DAWG a w b -> ID -> Maybe b+valueBy dawg i = do+ dawg' <- D.byID i dawg+ D.lookup [] dawg'
tests/Properties.hs view
@@ -14,8 +14,7 @@ import NLP.Adict import qualified NLP.Adict.CostDiv as C-import qualified NLP.Adict.Trie as Trie-import qualified NLP.Adict.DAWG as DAWG+import qualified Data.DAWG.Static as DAWG -- | Check parameters. posRange :: (Int, Int)@@ -135,19 +134,19 @@ pBaseEqBrute :: CostDesc -> Positive Double -> String -> Lang -> Bool pBaseEqBrute costDesc kP xR lang = let br = (nub . map unWord) (bruteSearch cost k x ys)- ba = nub (findAll cost k x trie)+ ba = nub (findAll cost k x dawg) in br == ba where x = V.fromList xR cost = toCost costDesc k = getPositive kP- trie = Trie.fromLang (getWords lang)+ dawg = DAWG.fromLang (getWords lang) ys = [(V.fromList y, ()) | y <- getWords lang] unWord (word, v, w) = (V.toList word, v, w) pBaseEqNearest :: CostDivDesc -> Positive Double -> String -> Lang -> Bool pBaseEqNearest costDesc kP xR lang =- let ba = findAll cost k x trie+ let ba = findAll cost k x dawg nr = findNearest costDiv k x dawg in check ba nr where@@ -165,8 +164,7 @@ costDiv = toCostDiv costDesc cost = C.toCostInf costDiv - trie = Trie.fromLang (getWords lang)- dawg = DAWG.fromTrie trie+ dawg = DAWG.fromLang (getWords lang) nub :: Ord a => [a] -> [a] nub = S.toList . S.fromList