packages feed

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
@@ -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