hist-pl-fusion 0.3.0 → 0.4.0

raw patch · 3 files changed

+44/−287 lines, 3 filesdep −cmdargsdep ~hist-pl-lexiconPVP ok

version bump matches the API change (PVP)

Dependencies removed: cmdargs

Dependency ranges changed: hist-pl-lexicon

API changes (from Hackage documentation)

Files

• hist-pl-fusion.cabal +9/−9
• src/NLP/HistPL/Fusion.hs +35/−240
• tools/hist-pl-fuse.hs +0/−38

@@ -1,5 +1,5 @@ name:               hist-pl-fusion-version:            0.3.0+version:            0.4.0 synopsis:           Merging historical dictionary with PoliMorf description:     The library provides functions for merging historical dictionary@@ -25,7 +25,7 @@       , text-binary       , dawg >= 0.9 && < 0.10       , polimorf >= 0.7.1 && < 0.8-      , hist-pl-lexicon >= 0.3 && < 0.4+      , hist-pl-lexicon >= 0.4 && < 0.5      exposed-modules:         NLP.HistPL.Fusion@@ -36,10 +36,10 @@     type: git     location: https://github.com/kawu/hist-pl.git -executable hist-pl-fuse-    build-depends:-        binary-      , cmdargs-    hs-source-dirs: src, tools-    main-is: hist-pl-fuse.hs-    ghc-options: -Wall -O2+-- executable hist-pl-fuse+--     build-depends:+--         binary+--       , cmdargs+--     hs-source-dirs: src, tools+--     main-is: hist-pl-fuse.hs+--     ghc-options: -Wall -O2

@@ -3,43 +3,18 @@  module NLP.HistPL.Fusion (--- * Rule-  Rule (..)-, apply-, between- -- * Basic types-, UID+  UID , POS , Word , Base , IsBase  -- * Dictionary--- ** Entry-, Lex (..)-, LexKey (..)-, LexElem (..)-, LexSet-, mkLexSet-, unLexSet--- ** Dictionary-, Dict-, BaseDict-, FormDict-, mkDict-, unDict-, revDict-, lookup-, entries -- ** Bilateral , Bila (..) , mkBila , withForm--- ** Historical-, Hist-, mkHist-, HLex -- ** Contemporary , Poli , PLex@@ -56,185 +31,60 @@ , byForms , posFilter , sumChoice---- * Fusion-, Fused-, FLex-, Code (..)-, extend-, fuse ) where  import Prelude hiding (lookup) import Control.Applicative ((<$>), (<*>))-import Control.Arrow (first)-import Data.Binary (Binary, get, put) import Data.Text.Binary ()-import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Text as T import qualified Data.PoliMorf as P-import qualified Data.DAWG.Static as D -import qualified NLP.HistPL as H---- | A rule for translating a form into another form.-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)--instance Binary Rule where-    put Rule{..} = put cut >> put suffix-    get = Rule <$> get <*> get---- | Apply the rule.-apply :: Rule -> T.Text -> T.Text-apply r x = T.take (T.length x - cut r) x `T.append` suffix r---- | 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+import           NLP.HistPL.Lexicon (UID)+import qualified NLP.HistPL.Lexicon as H+import qualified NLP.HistPL.Util as H+import           NLP.HistPL.Dict  ------------------------------------------------------------------------ --- | Unique ID in historical dictionary.-type UID = Int  -- | Part of speech. type POS = T.Text + -- | Base form. type Base = T.Text + -- | Word form. type Word = T.Text + -- | Is the word form a base form? type IsBase = Bool ------------------------------------------------------------------------- --- | A lexical entry.-data Lex i a b = Lex-    { lexKey    :: LexKey i-    , lexElem   :: LexElem a b }-    deriving (Show, Eq, Ord)---- | Transform entry into a list.-listLex :: Lex i a b -> [(T.Text, i, a, T.Text, b)]-listLex Lex{..} =-    [ (key, uid, info, word, y)-    | (word, y) <- M.assocs forms ]-  where-    LexKey{..}  = lexKey-    LexElem{..} = lexElem---- | Lexical entry dictionary key.-data LexKey i = LexKey-    { key   :: T.Text-    , uid   :: i }-    deriving (Show, Eq, Ord)---- | Lexical entry info.-data LexElem a b = LexElem-    { info  :: a-    , forms :: M.Map Word b }-    deriving (Show, Eq, Ord)---- | A set of lexical entries in a map form.-type LexSet i a b = M.Map (LexKey i) (LexElem a b) ---- | Make lexical set from a list of entries.-mkLexSet :: Ord i => [Lex i a b] -> LexSet i a b-mkLexSet = M.fromList . map ((,) <$> lexKey <*> lexElem)---- | List lexical entries.-unLexSet :: LexSet i a b -> [Lex i a b]-unLexSet = map (uncurry Lex) . M.toList----------------------------------------------------------------------------type RuleEntry i a b = M.Map i (a, M.Map Rule b)---- | One-way dictionary parametrized over ID @i@, with info @a@ for every--- (key, i) pair and info @b@ for every (key, i, apply rule key) triple.-type Dict i a b = D.DAWG Char () (M.Map i (a, M.Map Rule b))- -- | Dictionary keys represent base forms and rules transform base forms to -- their corresponding word forms.  Info @a@ is assigned to every lexeme -- and info @b@ to every word form. type BaseDict i a b = Dict i a b + -- | Dictionary keys represent word forms and rules transform word forms to -- their corresponding base forms.  Info @a@ is assigned to every lexeme -- and info @b@ to every word form. type FormDict i a b = Dict i a b --- | Decode dictionary entry.-decode :: Ord i => T.Text -> RuleEntry i a b -> LexSet i a b-decode key ruleEntry = mkLexSet-    [ Lex-        (LexKey key i)-        (LexElem x $ M.fromList-            [ (apply rule key, y)-            | (rule, y) <- M.assocs ruleMap ])-    | (i, (x, ruleMap)) <- M.assocs ruleEntry ] --- | Lookup the key in the dictionary.-lookup :: Ord i => T.Text -> Dict i a b -> LexSet i a b-lookup key dict = decode key $ case D.lookup (T.unpack key) dict of-    Just m  -> m-    Nothing -> M.empty---- | List dictionary lexical entries.-entries :: Ord i => Dict i a b -> [Lex i a b]-entries =-    let f = unLexSet . uncurry decode . first T.pack -    in  concatMap f . D.assocs---- | Make dictionary from a list of (key, ID, key\/ID info, elem,--- key\/ID\/elem info) tuples.-mkDict :: (Ord i, Ord a, Ord b) => [(T.Text, i, a, T.Text, b)] -> Dict i a b-mkDict xs = D.fromListWith union $-    [ ( T.unpack x-      , M.singleton i-        (a, M.singleton (between x y) b) )-    | (x, i, a, y, b) <- xs ]-  where-    union = M.unionWith $ both const M.union-    both f g (x, y) (x', y') = (f x x', g y y')---- | Transform dictionary back into the list of (key, ID, key\/ID info, elem,--- key\/ID\/elem info) tuples.-unDict :: (Ord i, Ord a, Ord b) => Dict i a b -> [(T.Text, i, a, T.Text, b)]-unDict = concatMap listLex . entries---- | Reverse the dictionary.-revDict :: (Ord i, Ord a, Ord b) => Dict i a b -> Dict i a b-revDict = -    let swap (base, i, x, form, y) = (form, i, x, base, y)-    in  mkDict . map swap . unDict- ------------------------------------------------------------------------ + -- | Bilateral dictionary. data Bila i a b = Bila     { baseDict  :: BaseDict i a b     , formDict  :: FormDict i a b }     deriving (Show, Eq, Ord) -instance (Ord i, Binary i, Binary a, Binary b) => Binary (Bila i a b) where-    put Bila{..} = put baseDict >> put formDict-    get = Bila <$> get <*> get  -- | Make bilateral dictionary from a list of (base form, ID, additional -- lexeme info, word form, additional word form info) tuples.@@ -243,65 +93,47 @@     { baseDict  = baseDict'     , formDict  = formDict' }   where-    baseDict'   = mkDict xs+    baseDict'   = fromList xs     formDict'   = revDict baseDict' + -- | Identify entries which contain given word form. withForm :: Ord i => Bila i a b -> Word -> LexSet i a b withForm Bila{..} word = M.unions     [ lookup base baseDict-    | (_, lexElem) <- M.assocs (lookup word formDict)-    , base <- M.keys (forms lexElem) ]+    | let lexSet = lookup word formDict+    , (_, val) <- M.assocs lexSet+    , base <- M.keys (forms val) ] + ------------------------------------------------------------------------ + -- | PoliMorf dictionary in a bilateral form. type Poli = Bila POS () () + -- | PoliMorf dictionary entry. type PLex = Lex POS () () + -- | Set of PoliMorf dictionary entries. type PLexSet = LexSet POS () () + -- | Make bilateral dictionary from PoliMorf. mkPoli :: [P.Entry] -> Poli mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form) ------------------------------------------------------------------------- --- | Historical dictionary.-type Hist = BaseDict UID (S.Set POS) IsBase---- | Historical dictionary entry.-type HLex = Lex UID (S.Set POS) IsBase---- | Construct historical dictionary.-mkHist :: [H.BinEntry] -> Hist-mkHist xs = mkDict-    [ ( H.keyForm key-      , H.keyUid key-      , S.fromList (H.pos entry)-      , form-      , isBase )-    | binEntry <- xs-    , let key = H.binKey binEntry-    , let entry = H.lexEntry binEntry-    , (form, isBase) <--        map (,True) (lemmas entry) ++-        map (,False) (forms entry)-    , oneWord form ]-  where-    lemmas = H.text . H.lemma-    forms  = concatMap H.text . H.forms-    oneWord = (==1) . length . T.words- ------------------------------------------------------------------------ + -- | A function which determines entries from a bilateral -- dictionary corresponing to a given historical lexeme.-type Corresp = Poli -> HLex -> PLexSet+type Corresp = Poli -> H.LexEntry -> PLexSet + -- | We provide three component types, `Core`, `Filter` and `Choice`, which -- can be combined together using the `buildCorresp` function to construct -- a `Corresp` function.  The first one, `Core`, is used to identify a list@@ -310,78 +142,41 @@ -- be usually divided into a set of smaller tasks of the same purpose. -- For example, we may want to identify `LexSet`s corresponding to individual -- word forms of the historical lexeme.-type Core = Poli -> HLex -> [PLexSet]+type Core = Poli -> H.LexEntry -> [PLexSet] + -- | Function which can be used to filter out lexemes which do not -- satisfy a particular predicate.  For example, we may want to filter -- out lexemes with incompatible POS value.-type Filter = HLex -> PLex -> Bool+type Filter = H.LexEntry -> PLex -> Bool + -- | The final choice of lexemes.  Many different strategies can be used--- here -- sum of the sets, intersection, or voting.+-- here sum of the sets, intersection, or voting. type Choice = [PLexSet] -> PLexSet + -- | Identify `LexSet`s corresponding to individual word forms of the -- historical lexeme using the `withForm` function. byForms :: Core-byForms bila Lex{..} =+byForms bila lexEntry =     [ withForm bila word-    | word <- M.keys (forms lexElem) ]+    | word <- H.allForms lexEntry ] + -- | Filter out lexemes with POS value incompatible with the -- set of POS values assigned to the historical lexeme. posFilter :: Filter-posFilter h p = uid (lexKey p) `S.member` info (lexElem h)+posFilter h p = uid (lexKey p) `elem` H.pos h + -- | Sum of sets of lexemes. sumChoice :: Choice sumChoice = M.unions + -- | Build `Corresp` function form individual components. buildCorresp :: Core -> Filter -> Choice -> Corresp buildCorresp core filt choice bila hLex =     let filterSet = mkLexSet . filter (filt hLex) . unLexSet     in  choice . map filterSet . core bila $ hLex------------------------------------------------------------------------------ | Fused dictionary.-type Fused = BaseDict UID () Code---- | Fused dictionary entry.-type FLex = Lex UID () Code---- | Code of word form origin.-data Code-    = Orig  -- ^ original (was already present in `HLex`)-    | Copy  -- ^ a copy (from corresponding lexeme)-    deriving (Show, Eq, Ord)--instance Binary Code where-    put Orig = put '1'-    put Copy = put '2'-    get = get >>= \x -> return $ case x of-        '1' -> Orig-        '2' -> Copy-        c   -> error $ "get: invalid Code value '" ++ [c] ++ "'"---- | Extend lexeme with forms from the set of lexemes.-extend :: HLex -> PLexSet -> FLex-extend hLex lexSet = subForms . M.fromList $-    concatMap (fromElem Copy) (M.elems lexSet) ++-    fromElem Orig (lexElem hLex)-  where-    subForms x = hLex { lexElem = LexElem () x }-    fromElem code = map (,code) . (M.keys . forms)---- | Fuse the historical dictionary with bilateral contemporary--- dictionary using the given `Corresp` function to determine--- contemporary lexemes corresponding to individual lexemes--- from the historical dictionary.-fuse :: Corresp -> Hist -> Poli -> Fused-fuse corr hist bila = mkDict-    [ (key, uid, (), word, code)-    | hLex <- entries hist-    , let Lex{..} = extend hLex (corr bila hLex)-    , let LexKey{..} = lexKey-    , (word, code) <- M.assocs (forms lexElem) ]

@@ -1,38 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}--import           Control.Applicative ((<$>))-import           System.Console.CmdArgs-import           Data.Binary (encodeFile)--import qualified Data.PoliMorf as P-import qualified NLP.HistPL as H-import qualified NLP.HistPL.Fusion as F--data HistPL_Fuse = HistPL_Fuse-    { histPath      :: FilePath-    , poliPath      :: FilePath-    , outPath       :: FilePath }-  deriving (Data, Typeable, Show)--histFuse :: HistPL_Fuse-histFuse = HistPL_Fuse-    { histPath = def &= typ "HistPL-Binary" &= argPos 0-    , poliPath = def &= typ "PoliMorf" &= argPos 1-    , outPath  = def &= typ "Output-Analysis-DAWG" &= argPos 2 }--main :: IO ()-main = exec =<< cmdArgs histFuse--exec :: HistPL_Fuse -> IO ()-exec HistPL_Fuse{..} = do-    poli <- F.mkPoli . filter P.atomic <$> P.readPoliMorf poliPath-    hist <- H.load histPath >>= \x -> case x of-    	Nothing -> error "hist-pl-fuse: not a binary historical dictionary"-	Just xs -> return $ F.mkHist xs-    let dict = F.fuse corr hist poli-    encodeFile outPath (F.revDict dict)-  where-    corr = F.buildCorresp F.byForms F.posFilter F.sumChoice