polimorf 0.4.1 → 0.5.0

raw patch · 2 files changed

+135/−46 lines, 2 filesdep +dawgPVP ok

version bump matches the API change (PVP)

Dependencies added: dawg

API changes (from Hackage documentation)

Files

• Data/PoliMorf.hs +133/−45
• polimorf.cabal +2/−1

@@ -1,3 +1,4 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE BangPatterns #-} @@ -8,35 +9,45 @@  module Data.PoliMorf ( --- * Types+-- * Core types   Form , Base , Tag , Cat , Entry (..)+, atomic  -- * Parsing , readPoliMorf , parsePoliMorf  -- * Merging+, Rule (..)+, apply+, toBase+, mkRuleMap , BaseMap , mkBaseMap+, FormMap+, mkFormMap , RelCode (..)+, mergeWith , merge ) where  import Control.Applicative ((<$>), (<*>)) import Data.Maybe (catMaybes) import Data.Monoid (mappend)-import Data.List (foldl') import Data.Binary (Binary, get, put)-import qualified Data.Map as M import qualified Data.Set as S+import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.IO as L+import qualified Data.DAWG as D +import Debug.Trace (trace)+ -- | A form. type Form = T.Text @@ -57,6 +68,15 @@     , cat  :: !Cat }     deriving (Eq, Ord, Show, Read) +-- | Is the entry an atomic one?  More precisely, we treat all negative+-- forms starting with ''nie'' and all superlatives starting with ''naj''+-- as non-atomic entries.+atomic :: Entry -> Bool+atomic x+    | "sup" `T.isInfixOf` tag x && "naj" `T.isPrefixOf` form x = False+    | "neg" `T.isInfixOf` tag x && "nie" `T.isPrefixOf` form x = False+    | otherwise = True+ -- | Read the PoliMorf from the file. readPoliMorf :: FilePath -> IO [Entry] readPoliMorf path = parsePoliMorf <$> L.readFile path@@ -71,25 +91,74 @@     [_form, _base, _tag, _cat] -> Entry _form _base _tag _cat     _   -> error $ "parsePoliRow: invalid row \"" ++ L.unpack row ++ "\"" +-- | A rule for translating a form into another one.+data Rule = Rule {+    -- | Number of characters to cut from the end of the form.+      cut       :: !Int+    -- | A suffix to paste.+    , suffix    :: !T.Text }+    deriving (Show, Eq, Ord)++-- | Apply the rule.+apply :: Rule -> T.Text -> T.Text+apply r x = T.take (T.length x - cut r) x `T.append` suffix r++-- | Determine the rule needed to translate the form into its base form.+toBase :: Entry -> Maybe Rule+toBase x+    | "sup" `T.isInfixOf` tag x && "naj" `T.isPrefixOf` form x = Nothing+    | "neg" `T.isInfixOf` tag x && "nie" `T.isPrefixOf` form x = Nothing+    | otherwise =+        let k = lcp (form x) (base x)+        in  Just $ Rule (T.length (form x) - k) (T.drop k (base x))+  where+    lcp a b = case T.commonPrefixes a b of+        Just (c, _, _)  -> T.length c+        Nothing         -> trace (show (form x, base x)) 0++-- | Make a rule to translate between two strings.+between :: T.Text -> T.Text -> Rule+between source dest =+    let k = lcp source dest+    in  Rule (T.length source - k) (T.drop k dest)+  where+    lcp a b = case T.commonPrefixes a b of+        Just (c, _, _)  -> T.length c+        Nothing         -> 0+ -- | A map from forms to their possible base forms (there may be many since -- the form may be a member of multiple lexemes).-type BaseMap = M.Map Form (S.Set Base)+type BaseMap = D.DAWG (S.Set Rule) --- | Make the base map from the list of entries.+-- | A map from base forms to all their potential forms.+type FormMap = D.DAWG (S.Set Rule)++-- | Make a rule map from a list of entries.+mkRuleMap :: [(T.Text, T.Text)] -> D.DAWG (S.Set Rule)+mkRuleMap xs = D.fromListWith S.union $+    [ ( T.unpack x+      , S.singleton (between x y) )+    | (x, y) <- xs ]++-- | Make a 'BaseMap' from a list of entries. mkBaseMap :: [Entry] -> BaseMap-mkBaseMap = M.fromListWith S.union . map ((,) <$> form <*> S.singleton . base)+mkBaseMap = mkRuleMap . map ((,) <$> form <*> base) +-- | Make a 'FormMap' from a list of entries.+mkFormMap :: [Entry] -> FormMap+mkFormMap = mkRuleMap . map ((,) <$> base <*> form)+ -- | Reliability information: how did we assign a particular label to -- a particular word form. data RelCode-    = Exact     -- ^ Label assigned in a direct manner+    = ByForm    -- ^ Based on labels of other forms within the same lexeme     | ByBase    -- ^ Label assigned based on a lemma label  -    | ByForm    -- ^ Based on labels of other forms within the same lexeme+    | Exact     -- ^ Label assigned in a direct manner     deriving (Eq, Ord, Show, Read)  instance Binary RelCode where     put Exact   = put '1'-    put ByBase = put '2'+    put ByBase  = put '2'     put ByForm  = put '3'     get = get >>= \x -> return $ case x of         '1' -> Exact@@ -97,63 +166,82 @@         '3' -> ByForm         c   -> error $ "get: invalid RelCode code '" ++ [c] ++ "'" --- | Merge the 'BaseMap' with the dictionary resource which maps forms to--- sets of labels.  Every label is assigned a 'RelCode' which tells what--- is the relation between the label and the form.  There are three--- kinds of labels:+-- | Merge the 'BaseMap' with the dictionary resource which maps forms to sets+-- of labels.  Every label is assigned a 'RelCode' which tells what is the+-- relation between the label and the form. It is a generalized version+-- of the 'merge' function with additional function @f x y y'label@ which+-- can be used to determine the resultant set of labels for the form @x@+-- given ,,similar'' form @y@ and its original label @y'label@.+-- There are three kinds of labels: -- 'Exact' labels assigned in a direct manner, 'ByBase' labels assigned -- to all forms which have a base form with a label in the input dictionary, -- and 'ByForm' labels assigned to all forms which have a related form from the -- same lexeme with a label in the input dictionary.------ This function is far from being memory efficient right now.  If you plan to--- run it with respect to the entire PoliMorf dictionary you should do it--- on a machine with an abundance of available memory.-merge-    :: Ord a => BaseMap-    -> M.Map Form (S.Set a)-    -> M.Map Form (M.Map a RelCode)-merge poli dict0 = M.fromList+mergeWith+    :: Ord a+    => (String -> String -> a -> a)+    -> BaseMap+    -> D.DAWG (S.Set a)+    -> D.DAWG (M.Map a RelCode)+mergeWith f poli dict0 = D.fromList     [ (x, combine x)     | x <- keys ]   where     -- Keys in the output dictionary.-    keys = S.toList (M.keysSet poli `S.union` M.keysSet dict0)+    keys = join (D.keys poli) (D.keys dict0)      -- Combining function.-    combine x = (M.unionsWith min . catMaybes)-        [ label Exact  <$> M.lookup x dict0 -        , label ByBase <$> M.lookup x dict1-        , label ByForm <$> M.lookup x dict2 ]+    combine x = (M.unionsWith max . catMaybes)+        [ label Exact  <$> D.lookup x dict0 +        , label ByBase <$> D.lookup x dict1+        , label ByForm <$> D.lookup x dict2 ]      label :: Ord a => RelCode -> S.Set a -> M.Map a RelCode     label code s = M.fromList [(x, code) | x <- S.toList s]      -- Extended to all base forms of dict0 keys.-    dict1 = fromListWith mappend-        [ (lemma, x)-        | (_form, x) <- M.assocs dict0+    dict1 = D.fromListWith mappend+        [ (lemma, f'Set lemma _form x)+        | (_form, x) <- D.assocs dict0         , lemma <- elemsOn poli _form ]      -- Extended to all forms of dict0 keys.-    dict2 = fromListWith mappend-        [ (form', x)-        | (_form, x) <- M.assocs dict0+    dict2 = D.fromListWith mappend+        [ (form', f'Set form' _form x)+        | (_form, x) <- D.assocs dict0         , lemma <- elemsOn poli _form         , form' <- elemsOn ilop lemma ]      -- Inverse poli dictionary.-    ilop = fromListWith mappend-        [ (lemma, S.singleton _form)-        | (_form, lemmas) <- M.assocs poli-        , lemma <- S.toList lemmas ]+    ilop = mkRuleMap+        [ (base'Text, form'Text)+        | (form'String, rules) <- D.assocs poli+        , rule <- S.toList rules+        , let form'Text = T.pack form'String+        , let base'Text = apply rule form'Text ]+    +    -- Merge to ascending lists.+    join (x:xs) (y:ys)+        | x < y     = x : join xs (y:ys)+        | x > y     = y : join (x:xs) ys+        | otherwise = x : join xs ys+    join xs []  = xs+    join [] ys  = ys -elemsOn :: (Ord a, Ord b) => M.Map a (S.Set b) -> a -> [b]-elemsOn m x = case x `M.lookup` m of-    Just s  -> S.toList s-    Nothing -> []+    -- Version of f function working on label sets.+    f'Set v w = S.fromList . map (f v w) . S.toList -fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> M.Map k a-fromListWith f xs =-    let update m (!k, !x) = M.insertWith' f k x m-    in  foldl' update M.empty xs+-- | A specialized version of the 'mergeWith' function which doesn't+-- change labels in the resultant 'D.DAWG'.+merge+    :: Ord a => BaseMap+    -> D.DAWG (S.Set a)+    -> D.DAWG (M.Map a RelCode)+merge = mergeWith $ \_ _ x -> x++elemsOn :: D.DAWG (S.Set Rule) -> String -> [String]+elemsOn m x = case x `D.lookup` m of+    Just s  ->+        [ T.unpack . apply rule . T.pack $ x+        | rule <- S.toList s ]+    Nothing -> []

@@ -1,5 +1,5 @@ name:               polimorf-version:            0.4.1+version:            0.5.0 synopsis:           Working with the PoliMorf dictionary description:     The library provides functionality for manipulating PoliMorf, the@@ -23,6 +23,7 @@       , containers       , text       , binary+      , dawg >= 0.5 && < 0.6      exposed-modules:         Data.PoliMorf