packages feed

adict (empty) → 0.1.0

raw patch · 14 files changed

+978/−0 lines, 14 filesdep +QuickCheckdep +adictdep +arraysetup-changed

Dependencies added: QuickCheck, adict, array, base, binary, containers, pqueue, test-framework, test-framework-quickcheck2, vector

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2012, IPI PAN+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ NLP/Adict/Basic.hs view
@@ -0,0 +1,61 @@+module NLP.Adict.Basic+( search+) 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 hiding (insert)++-- | Find all words within a trie with restricted generalized edit distance+-- lower or equall to k.+search :: Cost a -> Double -> Word a -> TrieD a b -> [([a], b, Double)]+search cost k x trie =+    foundHere ++ foundLower+  where+    foundHere+        | dist' m <= k = case valueIn 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, TrieD a b) -> [([a], b, Double)]+search' cost k distP x (c, trie) =+    foundHere ++ map appendChar foundLower+  where+    foundHere+        | dist' m <= k = case valueIn trie of+            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 view
@@ -0,0 +1,20 @@+module NLP.Adict.Brute+( search+) 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.+search :: Cost a -> Double -> Word a -> [(Word a, b)] -> [(Word a, b, Double)]+search 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 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 (#) #-}++-- | Word with 'a' character type.+type Word a = V.Vector a++-- | Position.+type Pos = Int++-- | Cost of edit operation.  It has to be non-negative!+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.+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 view
@@ -0,0 +1,99 @@+{-# LANGUAGE RecordWildCards #-}++module NLP.Adict.CostDiv+( Group (..)+, CostDiv (..)+, mapWeight+, costDefault++, Sub+, mkSub+, unSub+, SubMap+, subOn+, mkSubMap++, 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 together with appropriate+-- implementation: Choice Char Weight+data Group a = Filter+    { predic :: a -> Bool+    , weight :: Weight }++mapWeight :: (Weight -> Weight) -> Group a -> Group a+mapWeight f g = g { weight = f (weight g) }+           +-- | Cost function with edit operations divided with respect to weight.+-- Two operations with the same cost should be assigned to the same group.+data CostDiv a = CostDiv+    { insert ::        [Group a]+    , delete :: a   -> Weight+    , subst  :: a   -> [Group a]+    , posMod :: Pos -> Weight }++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 desription for some character x.+type Sub a = M.Map Weight (S.Set a)++mkSub :: Ord a => [(a, Weight)] -> Sub a+mkSub xs = M.fromListWith S.union [(w, S.singleton x) | (x, w) <- xs]++unSub :: Ord a => Sub a -> [Group a]+unSub sub =+    [ Filter (`S.member` charSet) weight+    | (weight, charSet) <- M.toAscList sub ]++-- | Susbtitution map for an alphabet.+type SubMap a = M.Map a (Sub a)++subOn :: Ord a => a -> SubMap a -> Sub a+subOn x sm = case M.lookup x sm of+    Just sd -> sd+    Nothing -> M.empty++mkSubMap :: Ord a => [(a, a, Weight)] -> SubMap a+mkSubMap xs = fmap mkSub $+    M.fromListWith (++)+        [ (x, [(y, w)])+        | (x, y, w) <- xs ]++-- | Transform CostDiv to plain Cost function with default weight value.+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 view
@@ -0,0 +1,102 @@+{-# LANGUAGE RecordWildCards #-}++module NLP.Adict.DAWG+( DAWGD+, DAWG (..)+, size+, row+, Row (..)+, entry+, charOn+, valueIn+, edges+, edgeOn++, serialize+, deserialize+) where++import Control.Applicative ((<$>))+import Data.Maybe (listToMaybe)+import Data.Binary (Binary, get, put)+import qualified Data.Vector as V++import NLP.Adict.DAWG.Node++type DAWGD a b = DAWG a (Maybe b)++data DAWG a b = DAWG+    { root  :: Int+    , array :: V.Vector (Row a b) }++size :: DAWG a b -> Int+size = V.length . array+{-# INLINE size #-}++row :: DAWG a b -> Int -> Row a b+row dag k = array dag V.! k+{-# INLINE row #-}++data Row a b = Row+    { rowValue :: b+    , rowEdges :: V.Vector (a, Int) }++valueIn :: DAWG a b -> Int -> b+valueIn dag k = rowValue (array dag V.! k)+{-# INLINE valueIn #-}++edges :: DAWG a b -> Int -> [(a, Int)]+edges dag k = V.toList . rowEdges $ row dag k+{-# INLINE edges #-}++edgeOn :: Eq a => DAWG a b -> Int -> a -> Maybe Int+edgeOn DAWG{..} k x =+    let r = array V.! k+    in  snd <$> V.find ((x==).fst) (rowEdges r)++entry :: DAWG a (Maybe b) -> [Int] -> Maybe ([a], b)+entry dag xs = do+    x <- mapM (charOn dag) (zip (root dag:xs) xs)+    r <- maybeLast xs >>= valueIn dag +    return (x, r)+  where+    maybeLast [] = Nothing+    maybeLast ys = Just $ last ys++charOn :: DAWG a b -> (Int, Int) -> Maybe a+charOn dag (root, x) = listToMaybe+    [c | (c, y) <- edges dag root, x == y]++serialize :: Ord a => DAWG a b -> [Node a b]+serialize = map unRow . V.toList . array++-- | Assumptiom: root node is last in the serialization list.+deserialize :: Ord a => [Node a b] -> DAWG a b+deserialize xs =+    let arr = V.fromList $ map mkRow xs+    in  DAWG (V.length arr - 1) arr++unRow :: Ord a => Row a b -> Node a b+unRow Row{..} = mkNode rowValue (V.toList rowEdges)+{-# INLINE unRow #-}++mkRow :: Ord a => Node a b -> Row a b+mkRow n = Row (nodeValue n) (V.fromList $ nodeEdges n)+{-# INLINE mkRow #-}++instance (Ord a, Binary a, Binary b) => Binary (DAWG a b) where+    put = put . serialize+    get = deserialize <$> get++-- goDown :: DAWG a -> Int -> DAWG a+-- goDown DAWG{..} k = DAWG k array+-- +-- instance T.Trie DAWGArray where+--     unTrie dag@DAWGArray{..} =+--         let row = array V.! root+--         in  ( valueIn row+--             , [ (c, goDown dag k)+--               | (c, k) <- U.toList (edgeVec row) ] )+--     child x dag@DAWGArray{..} =+--         let row = array V.! root+--         in  goDown dag <$> snd <$> U.find ((x==).fst) (edgeVec row)
+ NLP/Adict/DAWG/Node.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module NLP.Adict.DAWG.Node+( Node+, mkNode+, nodeValue+, nodeEdges+) where++import Data.Binary (Binary)++newtype Node a b = Node { unNode :: (b, [(a, Int)]) }+    deriving (Show, Eq, Ord, Binary)++mkNode :: b -> [(a, Int)] -> Node a b+mkNode x xs = Node (x, xs)++nodeValue :: Node a b -> b+nodeValue = fst . unNode++nodeEdges :: Node a b -> [(a, Int)]+nodeEdges = snd . unNode
+ 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) ]
+ NLP/Adict/Graph.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeSynonymInstances #-}++module NLP.Adict.Graph+( minPath+, Edges+, IsEnd+) where++import Data.Function (on)+import qualified Data.PQueue.Min 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 ascending order.+-- We use new data type to implement custom Eq and Ord instances.+data Adj n w = Adj+    { from :: n+    , to   :: [(w, n)] }+    deriving Show++proxy :: Adj n w -> (w, n)+proxy = head . to+{-# INLINE proxy #-}++folls :: Adj n w -> [(w, n)]+folls = tail . to+{-# INLINE folls #-}++instance (Eq n, Eq w) => Eq (Adj n w) where+    (==) = (==) `on` proxy++instance (Ord n, Ord w) => Ord (Adj n w) where+    compare = compare `on` proxy++-- | Remove minimal edge (from, weight, to) from the queue.+minView :: (Ord n, Ord w) => P.MinQueue (Adj n w)+        -> Maybe (Edge n w, P.MinQueue (Adj n w))+minView queue = do+    (adj, queue') <- P.minView queue+    let p       = from adj+        (w, q)  = proxy adj+        e       = (p, w, q)+    return (e, push queue' p (folls adj))++push :: (Ord n, Ord w) => P.MinQueue (Adj n w) -> n+     -> [(w, n)] -> P.MinQueue (Adj n w)+push queue _ [] = queue+push queue p xs = P.insert (Adj p xs) queue++-- | Find shortes path from a beginning node to any ending node.+minPath :: (Show n, Show w, 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 $ P.singleton (Adj beg [(0, beg)])++  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 view
@@ -0,0 +1,82 @@+module NLP.Adict.Nearest+( search+) 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+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 #-}++-- | We can check, if CostDiv satisfies basic properties.  On the other+-- hand, we do not do this for plain Cost function.+search :: Show a => CostDiv a -> Double -> Word a -> DAWGD a b -> Maybe ([a], b, Double)+search cost z x dag = do+    (xs, w) <- minPath z edgesFrom isEnd (Node (root dag) 0 Nothing)+    let form = catMaybes . map nodeChar $ xs+    r <- valueIn dag $ nodeID $ last xs+    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 (valueIn dag n)
+ NLP/Adict/Trie.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}++module NLP.Adict.Trie+( TrieD+, Trie (..)+, unTrie+, child+, anyChild+, mkTrie+, setValue+, substChild+, insert++, size+, follow+, lookup+, fromLang+, fromList+, toList++, serialize+, deserialize+, toDAWG+) where++import Prelude hiding (lookup)+import Control.Applicative ((<$>), (<*>))+import Control.Monad ((>=>))+import Data.List (foldl')+import Data.Binary (Binary, get, put)+import qualified Data.Map as M++import NLP.Adict.DAWG.Node++type TrieD a b = Trie a (Maybe b)++data Trie a b = Trie+    { valueIn :: b+    , edgeMap :: M.Map a (Trie a b) }+    deriving (Show, Eq, Ord)++instance Functor (Trie a) where+    fmap f Trie{..} = Trie (f valueIn) (fmap (fmap f) edgeMap)++instance (Ord a, Binary a, Binary b) => Binary (Trie a b) where+    put Trie{..} = do+        put valueIn+        put edgeMap+    get = Trie <$> get <*> get++unTrie :: Trie a b -> (b, [(a, Trie a b)])+unTrie t = (valueIn t, M.toList $ edgeMap t)+{-# INLINE unTrie #-}++child :: Ord a => a -> Trie a b -> Maybe (Trie a b)+child x Trie{..} = x `M.lookup` edgeMap+{-# INLINE child #-}++anyChild :: Trie a b -> [(a, Trie a b)]+anyChild = snd . unTrie+{-# INLINE anyChild #-}++mkTrie :: Ord a => b -> [(a, Trie a b)] -> Trie a b+mkTrie !v !cs = Trie v (M.fromList cs)+{-# INLINE mkTrie #-}++empty :: Ord a => TrieD a b+empty = mkTrie Nothing []+{-# INLINE empty #-}++setValue :: b -> Trie a b -> Trie a b+setValue !x !t = t { valueIn = x }+{-# INLINE setValue #-}++substChild :: Ord a => a -> Trie a b -> Trie a b -> Trie a b+substChild !x !trie !newChild =+    let how _ = Just newChild+        !edges = M.alter how x (edgeMap trie)+    in trie { edgeMap = edges }+{-# INLINABLE substChild #-}+{-# SPECIALIZE substChild+    :: Char+    -> Trie Char b+    -> Trie Char b+    -> Trie Char b #-}++insert :: Ord a => [a] -> b -> TrieD a b -> TrieD a b+insert [] v t = setValue (Just v) t+insert (x:xs) v t = substChild x t . insert xs v $+    case child x t of+        Just t' -> t'+        Nothing -> empty+{-# INLINABLE insert #-}+{-# SPECIALIZE insert+    :: String -> b+    -> TrieD Char b+    -> TrieD Char b #-}++size :: Trie a b -> Int+size t = 1 + sum (map (size.snd) (anyChild t))++follow :: Ord a => [a] -> Trie a b -> Maybe (Trie a b)+follow xs t = foldr (>=>) return (map child xs) t++lookup :: Ord a => [a] -> TrieD a b -> Maybe b+lookup xs t = follow xs t >>= valueIn++fromList :: Ord a => [([a], b)] -> TrieD a b+fromList xs =+    let update t (x, v) = insert x v t+    in  foldl' update empty xs++toList :: TrieD a b -> [([a], b)]+toList t = case valueIn t of+    Just y -> ([], y) : lower+    Nothing -> lower+  where+    lower = concatMap goDown $ anyChild t+    goDown (x, t') = map (addChar x) $ toList t'+    addChar x (xs, y) = (x:xs, y)++fromLang :: Ord a => [[a]] -> TrieD a ()+fromLang xs = fromList [(x, ()) | x <- xs]++toDAWG :: (Ord a, Ord b) => Trie a b -> Trie a b+toDAWG = deserialize . serialize++serialize :: (Ord a, Ord b) => Trie a b -> [Node a b]+serialize r =+    [ mkNode (valueIn t)+        [ (c, m M.! s)+        | (c, s) <- anyChild t ]+    | t <- M.elems m' ]+  where+    m  = collect r+    m' = M.fromList [(y, x) | (x, y) <- M.toList m]++-- | FIXME: Null node list case.+deserialize :: (Ord a, Ord b) => [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
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ adict.cabal view
@@ -0,0 +1,57 @@+name:               adict+version:            0.1.0+synopsis:           Approximate dictionary searching+description:+    Approximate dictionary searching library.+license:            BSD3+license-file:       LICENSE+cabal-version:      >= 1.8+copyright:          Copyright (c) 2012 IPI PAN+author:             Jakub Waszczuk+maintainer:         waszczuk.kuba@gmail.com+stability:          experimental+category:           Natural Language Processing+homepage:           https://github.com/kawu/adict+build-type:         Simple++library+    build-depends:+        base >= 4 && < 5+      , containers+      , vector+      , array+      , pqueue+      , binary++    exposed-modules:+        NLP.Adict.Core+      , NLP.Adict.CostDiv+      , NLP.Adict.Dist+      , NLP.Adict.Brute+      , NLP.Adict.Trie+      , NLP.Adict.DAWG.Node+      , NLP.Adict.DAWG+      , NLP.Adict.Graph+      , NLP.Adict.Basic+      , NLP.Adict.Nearest++    ghc-options: -Wall -O2++test-suite tests+    type: exitcode-stdio-1.0+    hs-source-dirs: tests+    main-is: Properties.hs+    build-depends:+        base >= 4 && < 5.0+      , QuickCheck+      , containers+      , vector+      , test-framework >= 0.3.3+      , test-framework-quickcheck2 >= 0.2.9+      , adict++  ghc-options: -Wall++source-repository head+    type: git+    location: git://github.com/kawu/adict.git
+ tests/Properties.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE RecordWildCards #-}++-- | QuickCheck properties which should be satisfied by the Adict.++import Control.Applicative ((<$>), (<*>), (<|>), pure)+import Data.Maybe (fromJust)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Vector as V++import Test.QuickCheck+import Test.Framework (Test, defaultMain)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import NLP.Adict.Core+import qualified NLP.Adict.CostDiv as C+import qualified NLP.Adict.Brute as Br+import qualified NLP.Adict.Basic as Ba+import qualified NLP.Adict.Nearest as Nr+import qualified NLP.Adict.Trie as Trie+import qualified NLP.Adict.DAWG as DAWG++-- | Check parameters.+posRange :: (Int, Int)+posRange  = (0, 4)	-- ^ Position of random edit op++weightRange :: (Weight, Weight)+weightRange  = (0, 10)	-- ^ Weight of edit op ++posModRange :: (Double, Double)+posModRange  = (0.1, 2)	-- ^ Position modifier++descRange :: (Int, Int)+descRange = (0, 25)	-- ^ Number of random edit ops of given type++langRange :: (Int, Int)+langRange = (0, 25)	-- ^ Size of language++arbitraryPos :: Gen Pos+arbitraryPos = choose posRange++arbitraryPosMod :: Gen Double+arbitraryPosMod = choose posModRange++arbitraryWeight :: Gen Weight+arbitraryWeight = choose weightRange++arbitraryChar :: Gen Char+arbitraryChar = elements ['a'..'z']++arbitraryWord :: Gen String+arbitraryWord = listOf arbitraryChar++arbitraryLang :: (Int, Int) -> Gen [String]+arbitraryLang r = nub <$> (flip vectorOf arbitraryWord =<< choose r)++-- | Helper structure with Arbitrary instance (implementation below),+-- which can be transformed to the Adict Cost function.+data CostDesc = CostDesc+    { insD :: M.Map (Pos, Char) Weight+    , delD :: M.Map (Pos, Char) Weight+    , subD :: M.Map (Pos, Char, Char) Weight }+    deriving Show++-- | Construct Cost function from a description structure.+toCost :: CostDesc -> Cost Char+toCost CostDesc{..} = Cost ins del sub+  where+    ins i x = fromJust $ (i, x) `M.lookup` insD <|> return 1+    del i x = fromJust $ (i, x) `M.lookup` delD <|> return 1+    sub i x y = fromJust $ (i, x, y) `M.lookup` subD  <|> return (sub' x y)+    sub' x y+        | x == y    = 0+        | otherwise = 1++instance Arbitrary CostDesc where+    arbitrary = do+        ins <- M.fromList <$> mkList insElem +        del <- M.fromList <$> mkList delElem+        sub <- M.fromList <$> mkList subElem+        return $ CostDesc ins del sub+      where +	insElem  = (,)  <$> arbitraryPos <*> arbitraryChar+	delElem  = (,)  <$> arbitraryPos <*> arbitraryChar+	subElem  = (,,) <$> arbitraryPos <*> arbitraryChar <*> arbitraryChar+        mkList m = do+            k <- choose descRange+            vectorOf k ((,) <$> m <*> arbitraryWeight)++-- | Helper structure with Arbitrary instance,+-- which can be transformed to the Adict Cost function.+data CostDivDesc = CostDivDesc+    { insDivD :: [(Char, Weight)]+    , delDivD :: [(Char, Weight)]+    , subDivD :: [(Char, Char, Weight)]+    , posModD :: M.Map Pos Double }+    deriving Show++instance Arbitrary CostDivDesc where+    arbitrary = do+        ins <- mkList insElem +        del <- mkList delElem+        sub <- mkList subElem+        posMod <- M.fromList <$> mkList posElem+        return $ CostDivDesc ins del sub posMod+      where +	insElem  = (,)  <$> arbitraryChar <*> arbitraryWeight+	delElem  = (,)  <$> arbitraryChar <*> arbitraryWeight+	subElem  = (,,) <$> arbitraryChar <*> arbitraryChar <*> arbitraryWeight+	posElem  = (,)  <$> arbitraryPos <*> arbitraryPosMod+        mkList m = do+            k <- choose descRange+            vectorOf k m++-- | Construct Cost function from a description structure.+toCostDiv :: CostDivDesc -> C.CostDiv Char+toCostDiv CostDivDesc{..} = C.CostDiv ins del sub posMod+  where+    delMap = M.fromList delDivD+    subMap = C.mkSubMap subDivD+    ins = C.unSub . C.mkSub $ insDivD+    del x = fromJust $ x `M.lookup` delMap <|> pure 1+    sub x+        =  C.Filter (x==) 0+        :  C.unSub (C.subOn x subMap)+        ++ [C.Filter (const True) 1]+    posMod k = fromJust $ k `M.lookup` posModD <|> pure 1++-- | Custom language generation.+newtype Lang = Lang [String] deriving Show+getWords :: Lang -> [String]+getWords (Lang xs) = xs+instance Arbitrary Lang where+    arbitrary = Lang <$> arbitraryLang langRange++-- | QuickCheck property1: set of matching dictionary entries should+-- be the same no matter which searching function is used.+pBaseEqBrute :: CostDesc -> Positive Double -> String -> Lang -> Bool+pBaseEqBrute costDesc kP xR lang =+    let br = (nub . map unWord) (Br.search cost k x ys)+        ba = nub (Ba.search cost k x trie)+    in  br == ba+  where+    x = V.fromList xR+    cost = toCost costDesc+    k = getPositive kP+    trie = Trie.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 = Ba.search cost k x trie+        nr = Nr.search costDiv k x dawg+    in  check ba nr+  where+    check [] (Just _) = False+    check [] Nothing  = True+    check ys (Just y) = y `elem`+        ( let thd (_, _, c) = c+              m = minimum . map thd $ ys+          in  filter ((<=m) . thd) ys )+    check _  _        = False++    x = V.fromList xR+    k = getPositive kP++    costDiv = toCostDiv costDesc+    cost = C.toCostInf costDiv++    trie = Trie.fromLang (getWords lang)+    dawg = DAWG.deserialize . Trie.serialize $ trie++nub :: Ord a => [a] -> [a]+nub = S.toList . S.fromList++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests =+    [ testProperty "brute force == basic" pBaseEqBrute+    , testProperty "nearest == minimum basic" pBaseEqNearest ]