packages feed

nerf 0.3.0 → 0.4.0

raw patch · 22 files changed

+980/−987 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

+ NLP.Nerf.Tokenize: word :: Word a => a -> String
- NLP.Nerf: ner :: Nerf -> [Word] -> NeForest NE Word
+ NLP.Nerf: ner :: Nerf -> String -> NeForest NE Word
- NLP.Nerf.Tokenize: moveNEs :: Word b => NeForest a b -> [b] -> NeForest a b
+ NLP.Nerf.Tokenize: moveNEs :: (Word b, Word c) => NeForest a b -> [c] -> NeForest a c

Files

− NLP/Nerf.hs 
@@ -1,96 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}---- | Main module of the Nerf tool.--module NLP.Nerf-( Nerf (..)-, train-, ner-, tryOx-, module NLP.Nerf.Types-) where--import Control.Applicative ((<$>), (<*>))-import Data.Binary (Binary, put, get)-import Data.Foldable (foldMap)-import Data.List (intercalate)-import qualified Data.Text as T-import qualified Data.Text.Lazy.IO as L--import Text.Named.Enamex (parseEnamex)-import qualified Data.Named.Tree as N-import qualified Data.Named.IOB as IOB--import Numeric.SGD (SgdArgs)-import qualified Data.CRF.Chain1 as CRF--import NLP.Nerf.Types-import NLP.Nerf.Tokenize (tokenize, moveNEs)-import NLP.Nerf.Schema (SchemaConf, Schema, fromConf, schematize)---- | A Nerf consists of the observation schema configuration and the CRF model.-data Nerf = Nerf-    { schemaConf    :: SchemaConf-    , crf           :: CRF.CRF Ob Lb }--instance Binary Nerf where-    put Nerf{..} = put schemaConf >> put crf-    get = Nerf <$> get <*> get--flatten :: Schema a -> N.NeForest NE Word -> CRF.SentL Ob Lb-flatten schema forest =-    [ CRF.annotate x y-    | (x, y) <- zip xs ys ]-  where-    iob = IOB.encodeForest forest-    xs = schematize schema (map IOB.word iob)-    ys = map IOB.label iob---- | Tokenize sentence with the Nerf tokenizer.-reTokenize :: N.NeForest NE Word -> N.NeForest NE Word-reTokenize ft = -    moveNEs ft ((doTok . leaves) ft)-  where -    doTok  = map T.pack . tokenize . intercalate " "  . map T.unpack-    leaves = concatMap $ foldMap (either (const []) (:[]))--readDeep :: FilePath -> IO [N.NeForest NE Word]-readDeep path = map reTokenize . parseEnamex <$> L.readFile path--readFlat :: Schema a -> FilePath -> IO [CRF.SentL Ob Lb]-readFlat schema path = map (flatten schema) <$> readDeep path--drawSent :: CRF.SentL Ob Lb -> IO ()-drawSent sent = do-    let unDist (x, y) = (x, CRF.unDist y)-    mapM_ (print . unDist) sent-    putStrLn "" ---- | Show results of observation extraction on the input ENAMEX file.-tryOx :: SchemaConf -> FilePath -> IO ()-tryOx cfg path = do-    input <- readFlat (fromConf cfg) path-    mapM_ drawSent input---- | Train Nerf on the input data using the SGD method.-train-    :: SgdArgs              -- ^ Args for SGD-    -> SchemaConf           -- ^ Observation schema configuration-    -> FilePath             -- ^ Train data (ENAMEX)-    -> Maybe FilePath       -- ^ Maybe eval data (ENAMEX)-    -> IO Nerf              -- ^ Nerf with resulting codec and model-train sgdArgs cfg trainPath evalPathM = do-    let schema = fromConf cfg-        readTrain = readFlat schema trainPath-        readEvalM = evalPathM >>= \evalPath ->-            Just ([], readFlat schema evalPath)-    _crf <- CRF.train sgdArgs readTrain readEvalM CRF.presentFeats-    return $ Nerf cfg _crf---- | Perform named entity recognition (NER) using the Nerf.-ner :: Nerf -> [Word] -> N.NeForest NE Word-ner nerf ws =-    let schema = fromConf (schemaConf nerf)-        xs = CRF.tag (crf nerf) (schematize schema ws)-    in  IOB.decodeForest [IOB.IOB w x | (w, x) <- zip ws xs]
− NLP/Nerf/Dict.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Extraction utilities for various dictionary resources.--module NLP.Nerf.Dict-( extractPoliMorf-, extractPNEG-, extractNELexicon-, extractProlexbase-, extractIntTriggers-, extractExtTriggers-, module NLP.Nerf.Dict.Base-) where--import Control.Applicative ((<$>), (<*>))-import qualified Data.PoliMorf as Poli--import NLP.Nerf.Dict.Base-import NLP.Nerf.Dict.PNEG (readPNEG)-import NLP.Nerf.Dict.NELexicon (readNELexicon)-import NLP.Nerf.Dict.Prolexbase (readProlexbase)-import qualified NLP.Nerf.Dict.PNET as PNET---- | Is it a single word entry?-atomic :: Entry -> Bool-atomic = not . isMultiWord . neOrth---- | Extract NEs dictionary from PNEG.-extractPNEG-    :: FilePath     -- ^ Path to PNEG in the LMF format-    -> IO Dict-extractPNEG lmfPath =-    fromEntries . filter atomic <$> readPNEG lmfPath---- | Extract NEs dictionary from NELexicon.-extractNELexicon-    :: FilePath     -- ^ Path to NELexicon-    -> IO Dict-extractNELexicon nePath =-    fromEntries . filter atomic <$> readNELexicon nePath---- | Extract NEs dictionary from PoliMorf.-extractPoliMorf-    :: FilePath     -- ^ Path to PoliMorf-    -> IO Dict-extractPoliMorf poliPath-    = fromPairs . filter (cond . snd)-    . map ((,) <$> Poli.form <*> Poli.cat)-    <$> Poli.readPoliMorf poliPath-  where-    cond x = x /= "pospolita" && x /= ""---- | Extract NEs dictionary from Prolexbase.-extractProlexbase-    :: FilePath     -- ^ Path to Prolexbase-    -> IO Dict-extractProlexbase proPath = do-    fromEntries . filter atomic <$> readProlexbase proPath---- | Extract internal triggers from PNET dictionary.-extractIntTriggers-    :: FilePath     -- ^ Path to PNET-    -> IO Dict-extractIntTriggers pnetPath =-    mkTriggers PNET.Internal <$> PNET.readPNET pnetPath---- | Extract external triggers from PNET dictionary.-extractExtTriggers-    :: FilePath     -- ^ Path to PNET-    -> IO Dict-extractExtTriggers pnetPath =-    mkTriggers PNET.External <$> PNET.readPNET pnetPath--mkTriggers :: PNET.Typ -> [PNET.Entry] -> Dict-mkTriggers typ-    = fromPairs-    . filter (not . isMultiWord . fst) -    . map ((,) <$> PNET.orth <*> PNET.neTyp)-    . filter (PNET.hasTyp typ)
− NLP/Nerf/Dict/Base.hs 
@@ -1,116 +0,0 @@-{-# LANGUAGE TupleSections #-}---- | Basic types for dictionary handling. --module NLP.Nerf.Dict.Base-(--- * Lexicon entry-  NeType-, Form-, isMultiWord-, Entry (..)---- * Dictionary-, Label-, DAWG-, Dict-, fromPairs-, fromEntries-, siftDict-, saveDict-, loadDict---- * Merging dictionaries-, merge-, diff-) where--import Control.Applicative ((<$>), (<*>))-import Data.Binary (encodeFile, decodeFile)-import Data.Text.Binary ()-import qualified Data.Text as T-import qualified Data.Set as S-import qualified Data.DAWG.Static as D-import qualified Data.DAWG.Trans.Vector as D---- | A type of named entity.-type NeType = T.Text---- | A orthographic form.-type Form = T.Text---- | Is the form a multiword one?-isMultiWord :: Form -> Bool-isMultiWord = (>1) . length . T.words---- | A Named Entity entry from the LMF dictionary.-data Entry = Entry-    { neOrth :: !Form	-- ^ Orthographic form of the NE-    , neType :: !NeType -- ^ Type of the NE-    } deriving (Show, Read, Eq, Ord)---- | Dictionary label.-type Label = T.Text---- | A 'Dict' is a map from forms to labels.  Each form may be annotated--- with multiple labels.  The map is represented using the directed acyclic--- word graph.--- type Dict = D.DAWG (S.Set Label)-type DAWG = D.DAWG D.Trans Char ()-type Dict = DAWG (S.Set Label)---- | Construct dictionary from the list of form/label pairs.-fromPairs :: [(Form, Label)] -> Dict-fromPairs xs = D.fromListWith S.union-    [ ( T.unpack x-      , S.singleton y)-    | (x, y) <- xs ]---- | Construct dictionary from the list of entries.-fromEntries :: [Entry] -> Dict-fromEntries = fromPairs . map ((,) <$> neOrth <*> neType)---- | Remove dictionary entries which do not satisfy the predicate.-siftDict :: (Form -> S.Set Label -> Bool) -> Dict -> Dict-siftDict f dict = D.fromList [(k, v) | (k, v) <- D.assocs dict, f (T.pack k) v]---- | Save the dictionary in the file.-saveDict :: FilePath -> Dict -> IO ()-saveDict = encodeFile---- | Load the dictionary from the file.-loadDict :: FilePath -> IO Dict-loadDict = decodeFile---- | Merge dictionary resources.-merge :: [Dict] -> Dict-merge = unionsWith S.union---- | Replacement implementation of unionsWith while there is--- no such function in dawg library. -unionsWith :: Ord a => (a -> a -> a) -> [DAWG a] -> DAWG a-unionsWith f = foldl (unionWith f) D.empty---- | Replacement implementation of unionWith while there is--- no such function in dawg library. -unionWith :: Ord a => (a -> a -> a) -> DAWG a -> DAWG a -> DAWG a-unionWith f d d' = D.fromListWith f (D.assocs d ++ D.assocs d')---- | Differentiate labels from separate dictionaries using--- dictionary-unique prefixes.-diff :: [Dict] -> [Dict]-diff ds =-    [ mapS (addPrefix i) `mapD` dict-    | (i, dict) <- zip [0..] ds ]---- | Map function over the DAWG elements.-mapD :: Ord b => (a -> b) -> DAWG a -> DAWG b-mapD f d = D.fromList [(x, f y) | (x, y) <- D.assocs d]---- | Map function over the set.-mapS :: Ord b => (a -> b) -> S.Set a -> S.Set b-mapS f s = S.fromList [f x | x <- S.toList s]---- | Add integer prefix.-addPrefix :: Int -> T.Text -> T.Text-addPrefix = T.append . T.pack . show
− NLP/Nerf/Dict/NELexicon.hs 
@@ -1,24 +0,0 @@--- | Handling the NELexicon dictionary.--module NLP.Nerf.Dict.NELexicon-( parseNELexicon-, readNELexicon-) where--import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L--import NLP.Nerf.Dict.Base---- | Parse the NELexicon into a list of entries.-parseNELexicon :: L.Text -> [Entry]-parseNELexicon = map parseLine . L.lines--parseLine :: L.Text -> Entry-parseLine line = case L.break (==';') line of-    (_type, _form) -> Entry (L.toStrict $ L.drop 2 _form) (L.toStrict _type)-    _   -> error $ "parseLine: invalid line \"" ++ L.unpack line ++ "\""---- | Read the dictionary from the file.-readNELexicon :: FilePath -> IO [Entry]-readNELexicon = fmap parseNELexicon . L.readFile
− NLP/Nerf/Dict/PNEG.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}---- | Parsing the Gazetteer for Polish Named Entities (used formerly within--- the SProUT platform) in the LMF format.--module NLP.Nerf.Dict.PNEG-( parsePNEG-, readPNEG-) where--import Text.XML.PolySoup-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L--import NLP.Nerf.Dict.Base--lmfP :: XmlParser L.Text [Entry]-lmfP = true ##> lexEntryP--lexEntryP :: XmlParser L.Text [Entry]-lexEntryP = tag "LexicalEntry" `joinR` do-    many_ $ cut $ tag "feat"-    _words <- many wordP-    sense  <- senseP-    return [Entry x sense | x <- _words]--wordP :: XmlParser L.Text Form-wordP = head <$> (tag "Lemma" <|> tag "WordForm" /> featP "writtenForm")--senseP :: XmlParser L.Text NeType-senseP = head <$> (tag "Sense" //> featP "externalReference" <|> featP "label")--featP :: L.Text -> XmlParser L.Text T.Text-featP x = L.toStrict <$> cut (tag "feat" *> hasAttr "att" x *> getAttr "val")---- | Parse the dictionary to the list of entries.-parsePNEG :: L.Text -> [Entry]-parsePNEG = parseXml lmfP---- | Read the dictionary from the file.-readPNEG :: FilePath -> IO [Entry]-readPNEG = fmap parsePNEG . L.readFile
− NLP/Nerf/Dict/PNET.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Polish Named Entity Triggers <http://zil.ipipan.waw.pl/PNET> dictionary.--module NLP.Nerf.Dict.PNET-( parsePNET-, readPNET-, Typ (..)-, hasTyp-, Entry (..)-) where--import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L---- | Trigger type.-data Typ-    = Internal-    | External-    deriving (Show, Eq, Ord)--readTyp :: T.Text -> Typ-readTyp "int" = Internal-readTyp "ext" = External-readTyp x     = error $ "readTyp: typ " ++ T.unpack x ++ " unknown"---- | PNET entry.-data Entry = Entry-    { orth      :: T.Text-    , base      :: T.Text-    , tag       :: T.Text-    , typ       :: Typ-    , neTyp     :: T.Text-    , example   :: T.Text }---- | Does entry represents a trigger of the given type?-hasTyp :: Typ -> Entry -> Bool-hasTyp x = (==x) . typ--parseLine :: L.Text -> Entry-parseLine line = case map L.toStrict (L.split (=='\t') line) of-    [_orth, _base, _tag, _typ, _neTyp, _example] ->-        Entry _orth _base _tag (readTyp _typ) _neTyp _example-    _   -> error $ "parseLine: invalid row \"" ++ L.unpack line ++ "\""---- | Parse dictionary into a list of entries.-parsePNET :: L.Text -> [Entry]-parsePNET = map parseLine . L.lines---- | Read dictionary from the file.-readPNET :: FilePath -> IO [Entry]-readPNET = fmap parsePNET . L.readFile
− NLP/Nerf/Dict/Prolexbase.hs 
@@ -1,25 +0,0 @@--- | Handling Prolexbase dictionaries, both with the--- same storage format.--module NLP.Nerf.Dict.Prolexbase-( parseProlexbase-, readProlexbase-) where--import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L--import NLP.Nerf.Dict.Base---- | Parse dictionary into a list of entries.-parseProlexbase :: L.Text -> [Entry]-parseProlexbase = map parseLine . L.lines--parseLine :: L.Text -> Entry-parseLine row = case map L.toStrict (L.split (=='\t') row) of-    [_form, _base, _tag, _cat] -> Entry _form _cat-    _   -> error $ "parseLine: invalid row \"" ++ L.unpack row ++ "\""---- | Read the dictionary from the file.-readProlexbase :: FilePath -> IO [Entry]-readProlexbase = fmap parseProlexbase . L.readFile
− NLP/Nerf/Schema.hs 
@@ -1,360 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}---- | Observation schema blocks for Nerf.--module NLP.Nerf.Schema-( --- * Types-  Ox-, Schema-, void-, sequenceS_---- * Usage-, schematize---- ** Configuration-, Body (..)-, Entry-, entry-, entryWith-, SchemaConf (..)-, nullConf-, defaultConf-, fromConf---- ** Schema blocks-, Block-, fromBlock-, orthB-, splitOrthB-, lowPrefixesB-, lowSuffixesB-, lemmaB-, shapeB-, packedB-, shapePairB-, packedPairB-, dictB-) where--import Control.Applicative ((<$>), (<*>))-import Control.Monad (forM_, join)-import Data.Maybe (maybeToList)-import Data.Binary (Binary, put, get)-import qualified Data.Char as C-import qualified Data.Set as S-import qualified Data.Vector as V-import qualified Data.Text as T-import qualified Data.DAWG.Static as D--import qualified Data.CRF.Chain1 as CRF-import qualified Control.Monad.Ox as Ox-import qualified Control.Monad.Ox.Text as Ox--import NLP.Nerf.Types-import NLP.Nerf.Dict (Dict)---- | The Ox monad specialized to word token type and text observations.-type Ox a = Ox.Ox Word T.Text a---- | A schema is a block of the Ox computation performed within the--- context of the sentence and the absolute sentence position.-type Schema a = V.Vector Word -> Int -> Ox a---- | A dummy schema block.-void :: a -> Schema a-void x _ _ = return x---- | Sequence the list of schemas (or blocks) and discard individual values.-sequenceS_ :: [V.Vector Word -> a -> Ox b] -> V.Vector Word -> a -> Ox ()-sequenceS_ xs sent =-    let ys = map ($sent) xs-    in  \k -> sequence_ (map ($k) ys)---- | Record structure of the basic observation types.-data BaseOb = BaseOb-    { orth          :: Int -> Maybe T.Text-    , lowOrth       :: Int -> Maybe T.Text }---- | Construct the 'BaseOb' structure given the sentence.-mkBaseOb :: V.Vector Word -> BaseOb-mkBaseOb sent = BaseOb-    { orth      = _orth-    , lowOrth   = _lowOrth }-  where-    at          = Ox.atWith sent-    _orth       = (id `at`)-    _lowOrth i  = T.toLower <$> _orth i---- | A block is a chunk of the Ox computation performed within the--- context of the sentence and the list of absolute sentence positions.-type Block a = V.Vector Word -> [Int] -> Ox a---- | Transform the block to the schema depending on the list of--- relative sentence positions.-fromBlock :: Block a -> [Int] -> Schema a-fromBlock blk xs sent =-    let blkSent = blk sent-    in  \k -> blkSent [x + k | x <- xs]---- | Orthographic form at the current position.-orthB :: Block ()-orthB sent = \ks ->-    let orthOb = Ox.atWith sent id-    in  mapM_ (Ox.save . orthOb) ks---- | Orthographic form split into two observations: the lowercased form and--- the original form (only when different than the lowercased one).-splitOrthB :: Block ()-splitOrthB sent = \ks -> do-    mapM_ (Ox.save . lowOrth)    ks-    mapM_ (Ox.save . upOnlyOrth) ks-  where-    BaseOb{..}      = mkBaseOb sent-    upOnlyOrth i    = orth i >>= \x -> case T.any C.isUpper x of-        True    -> Just x-        False   -> Nothing---- | List of lowercased prefixes of given lengths.-lowPrefixesB :: [Int] -> Block ()-lowPrefixesB ns sent = \ks ->-    forM_ ks $ \i ->-        mapM_ (Ox.save . lowPrefix i) ns-  where-    BaseOb{..}      = mkBaseOb sent-    lowPrefix i j   = Ox.prefix j =<< lowOrth i---- | List of lowercased suffixes of given lengths.-lowSuffixesB :: [Int] -> Block ()-lowSuffixesB ns sent = \ks ->-    forM_ ks $ \i ->-        mapM_ (Ox.save . lowSuffix i) ns-  where-    BaseOb{..}      = mkBaseOb sent-    lowSuffix i j   = Ox.suffix j =<< lowOrth i---- | Lemma substitute parametrized by the number specifying the span--- over which lowercased prefixes and suffixes will be 'Ox.save'd.--- For example, @lemmaB 2@ will take affixes of lengths @0, -1@ and @-2@--- on account.-lemmaB :: Int -> Block ()-lemmaB n sent = \ks -> do-    mapM_ lowLemma ks-  where-    BaseOb{..}      = mkBaseOb sent-    lowPrefix i j   = Ox.prefix j =<< lowOrth i-    lowSuffix i j   = Ox.suffix j =<< lowOrth i-    lowLemma i = Ox.group $ do-        mapM_ (Ox.save . lowPrefix i) [0, -1 .. -n]-        mapM_ (Ox.save . lowSuffix i) [0, -1 .. -n]---- | Shape of the word.-shapeB :: Block ()-shapeB sent = \ks -> do-    mapM_ (Ox.save . shape) ks-  where-    BaseOb{..}      = mkBaseOb sent-    shape i         = Ox.shape <$> orth i---- | Packed shape of the word.-packedB :: Block ()-packedB sent = \ks -> do-    mapM_ (Ox.save . shapeP) ks-  where-    BaseOb{..}      = mkBaseOb sent-    shape i         = Ox.shape <$> orth i-    shapeP i        = Ox.pack <$> shape i---- -- | Shape and packed shape of the word.--- shapeAndPackedB :: Block ()--- shapeAndPackedB sent = \ks -> do---     mapM_ (Ox.save . shape)  ks---     mapM_ (Ox.save . shapeP) ks---   where---     BaseOb{..}      = mkBaseOb sent---     shape i         = Ox.shape <$> orth i---     shapeP i        = Ox.pack <$> shape i---- | Combined shapes of two consecutive (at @k-1@ and @k@ positions) words.-shapePairB :: Block ()-shapePairB sent = \ks ->-    forM_ ks $ \i -> do-        Ox.save $ link <$> shape  i <*> shape  (i - 1)-  where-    BaseOb{..}      = mkBaseOb sent-    shape i         = Ox.shape <$> orth i-    link x y        = T.concat [x, "-", y]---- | Combined packed shapes of two consecutive (at @k-1@ and @k@ positions)--- words.-packedPairB :: Block ()-packedPairB sent = \ks ->-    forM_ ks $ \i -> do-        Ox.save $ link <$> shapeP i <*> shapeP (i - 1)-  where-    BaseOb{..}      = mkBaseOb sent-    shape i         = Ox.shape <$> orth i-    shapeP i        = Ox.pack <$> shape i-    link x y        = T.concat [x, "-", y]---- | Plain dictionary search determined with respect to the list of--- relative positions.-dictB :: Dict -> Block ()-dictB dict sent = \ks -> do-    mapM_ (Ox.saves . searchDict) ks-  where-    BaseOb{..}      = mkBaseOb sent-    searchDict i    = join . maybeToList $-        S.toList <$> (orth i >>= flip D.lookup dict . T.unpack)---- | Body of configuration entry.-data Body a = Body {-    -- | Range argument for the schema block. -      range :: [Int]-    -- | Additional arguments for the schema block.-    , args  :: a }-    deriving (Show)--instance Binary a => Binary (Body a) where-    put Body{..} = put range >> put args-    get = Body <$> get <*> get---- | Maybe entry.-type Entry a = Maybe (Body a)---- | Entry with additional arguemnts.-entryWith :: a -> [Int] -> Entry a-entryWith v xs = Just (Body xs v)---- | Maybe entry with additional arguemnts.-entryWith'Mb :: Maybe a -> [Int] -> Entry a-entryWith'Mb (Just v) xs = Just (Body xs v)-entryWith'Mb Nothing _   = Nothing---- | Plain entry with no additional arugments.-entry :: [Int] -> Entry ()-entry = entryWith ()---- | Configuration of the schema.  All configuration elements specify the--- range over which a particular observation type should be taken on account.--- For example, the @[-1, 0, 2]@ range means that observations of particular--- type will be extracted with respect to previous (@k - 1@), current (@k@)--- and after the next (@k + 2@) positions when identifying the observation--- set for position @k@ in the input sentence.-data SchemaConf = SchemaConf {-    -- | The 'orthB' schema block.-      orthC             :: Entry ()-    -- | The 'splitOrthB' schema block.-    , splitOrthC        :: Entry ()-    -- | The 'lowPrefixesB' schema block.  The first list of ints-    -- represents lengths of prefixes.-    , lowPrefixesC      :: Entry [Int]-    -- | The 'lowSuffixesB' schema block.  The first list of ints-    -- represents lengths of suffixes.-    , lowSuffixesC      :: Entry [Int]-    -- | The 'lemmaB' schema block.-    , lemmaC            :: Entry Int-    -- | The 'shapeB' schema block.-    , shapeC            :: Entry ()-    -- | The 'packedB' schema block.-    , packedC           :: Entry ()-    -- | The 'shapePairB' schema block.-    , shapePairC        :: Entry ()-    -- | The 'packedPairB' schema block.-    , packedPairC       :: Entry ()-    -- | Dictionaries of NEs ('dictB' schema block).-    , dictC             :: Entry [Dict]-    -- | Dictionary of internal triggers.-    , intTrigsC         :: Entry Dict-    -- | Dictionary of external triggers.-    , extTrigsC         :: Entry Dict-    } deriving (Show)--instance Binary SchemaConf where-    put SchemaConf{..} = do-        put orthC-        put splitOrthC-        put lowPrefixesC-        put lowSuffixesC-        put lemmaC-        put shapeC-        put packedC-        put shapePairC-        put packedPairC-        put dictC-        put intTrigsC-        put extTrigsC-    get = SchemaConf-        <$> get <*> get <*> get <*> get-        <*> get <*> get <*> get <*> get-        <*> get <*> get <*> get <*> get---- | Null configuration of the observation schema.-nullConf :: SchemaConf-nullConf = SchemaConf-    Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing-    Nothing Nothing Nothing Nothing---- | Default configuration of the observation schema.-defaultConf-    :: [Dict]       -- ^ Named Entity dictionaries-    -> Maybe Dict   -- ^ Dictionary of internal triggers-    -> Maybe Dict   -- ^ Dictionary of external triggers-    -> IO SchemaConf-defaultConf neDicts intDict extDict = do-    return $ SchemaConf-        { orthC         = Nothing-        , splitOrthC    = entry                 [-1, 0]-        , lowPrefixesC  = Nothing-        , lowSuffixesC  = entryWith [2, 3, 4]   [0]-        , lemmaC        = entryWith 3           [-1, 0]-        , shapeC        = entry                 [-1, 0]-        , packedC       = entry                 [-1, 0]-        , shapePairC    = entry                 [0]-        , packedPairC   = entry                 [0]-        , dictC         = entryWith neDicts     [-1, 0]-        , intTrigsC     = entryWith'Mb intDict  [0]-        , extTrigsC     = entryWith'Mb extDict  [-1] }--mkArg0 :: Block () -> Entry () -> Schema ()-mkArg0 blk (Just x) = fromBlock blk (range x)-mkArg0 _   Nothing  = void ()--mkArg1 :: (a -> Block ()) -> Entry a -> Schema ()-mkArg1 blk (Just x) = fromBlock (blk (args x)) (range x)-mkArg1 _   Nothing  = void ()--mkArgs1 :: (a -> Block ()) -> Entry [a] -> Schema ()-mkArgs1 blk (Just x) = sequenceS_-    [ fromBlock-        (blk dict)-        (range x)-    | dict <- args x ]-mkArgs1 _   Nothing  = void ()---- | Build the schema based on the configuration.-fromConf :: SchemaConf -> Schema ()-fromConf SchemaConf{..} = sequenceS_-    [ mkArg0 orthB orthC-    , mkArg0 splitOrthB splitOrthC-    , mkArg1 lowPrefixesB lowPrefixesC-    , mkArg1 lowSuffixesB lowSuffixesC-    , mkArg1 lemmaB lemmaC-    , mkArg0 shapeB shapeC-    , mkArg0 packedB packedC-    , mkArg0 shapePairB shapePairC-    , mkArg0 packedPairB packedPairC-    , mkArgs1 dictB dictC-    , mkArg1 dictB intTrigsC-    , mkArg1 dictB extTrigsC ]---- | Use the schema to extract observations from the sentence.-schematize :: Schema a -> [Word] -> CRF.Sent Ob-schematize schema xs =-    map (S.fromList . Ox.execOx . schema v) [0 .. n - 1]-  where-    v = V.fromList xs-    n = V.length v
− NLP/Nerf/Tokenize.hs 
@@ -1,151 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}---- | The module implements the tokenization used within Nerf--- and some other tokenization-related stuff.--module NLP.Nerf.Tokenize-(--- * Tokenization-  tokenize--- * Synchronization-, Word-, moveNEs-) where--import Control.Monad ((>=>))-import Data.Foldable (foldMap)-import qualified Data.Char as Char-import qualified Data.List as L-import qualified Data.Tree as T-import qualified Data.Traversable as Tr-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LazyText-import qualified NLP.Tokenize as Tok--import Data.Named.Tree (NeForest, NeTree, groupForestLeaves)-------------------------------- Tokenization definition.-------------------------------- | Default tokenizator.-defaultTokenizer :: Tok.Tokenizer-defaultTokenizer-    =   Tok.whitespace-    >=> Tok.uris-    >=> Tok.punctuation---- | Tokenize sentence using the default tokenizer.-tokenize :: String -> [String]-tokenize = Tok.run defaultTokenizer-------------------------------------------------------------------- Synchronizing named entities with new sentence tokenization.-------------------------------------------------------------------- | A class of objects with size.-class Word a where-    size        :: a -> Int-    rmSpaces    :: a -> a--instance Word String where-    size = length-    rmSpaces = filter (not . Char.isSpace)--instance Word Text.Text where-    size = Text.length-    rmSpaces = Text.filter (not . Char.isSpace)--instance Word LazyText.Text where-    size = fromInteger . toInteger . LazyText.length-    rmSpaces = LazyText.filter (not . Char.isSpace)--essence :: Word a => a -> Int-essence = size . rmSpaces-{-# INLINE essence #-}---- | Syncronization between two sentences.  Each (xs, ys) pair represents--- tokens from the two input sentences which corresponds to each other.-type Sync a = [([a], [a])]---- | Synchronize two tokenizations of the sentence.-sync :: Word a => [a] -> [a] -> Sync a-sync = sync' 0--sync' :: Word a => Int -> [a] -> [a] -> Sync a-sync' r (x:xs) (y:ys)-    | n + r == m    = ([x], [y])    : sync' 0       xs    ys-    | n + r  < m    = join x        $ sync' (n + r) xs (y:ys)-    | otherwise     = swap . join y $ sync' (m - r) ys (x:xs)-  where-    n = essence x-    m = essence y-    join l ((ls, rs) : ps)  = (l:ls, rs) : ps-    join _ []               = error "sync'.join: bad arguments"-    swap ((ls, rs) : ps)    = (rs, ls) : swap ps-    swap []                 = []-sync' 0 [] [] = []-sync' _ _  _  = error "sync': bad arguments"---- | Match the `Sync` with the given list, return the matching result--- (snd elements of the `Sync` list) and the rest of the `Sync` list.-match :: Word a => [a] -> Sync a -> ([a], Sync a)-match xs ss =-    let (sl, sr) = splitAcc isMatch 0 ss-    in  (concatMap snd sl, sr)-  where-    n = sum (map essence xs)-    isMatch r (ys, _)-        | m + r < n     = (m + r, False)-        | m + r == n    = (m + r, True)-        | otherwise     = error "match.isMatch: no match"-      where-        m = sum (map essence ys)---- | Split the list with the help of the accumulating function.-splitAcc :: (acc -> a -> (acc, Bool)) -> acc -> [a] -> ([a], [a])-splitAcc _ _ [] = ([], [])-splitAcc f acc (x:xs)-    | cond      = ([x], xs)-    | otherwise = join x (splitAcc f acc' xs)-  where-    (acc', cond) = f acc x-    join y (ys, zs) = (y:ys, zs)---- | List forest leaves.-leaves :: NeForest a b -> [b]-leaves = concatMap $ foldMap (either (const []) (:[]))--unGroupLeaves :: NeForest a [b] -> NeForest a b-unGroupLeaves = concatMap unGroupLeavesT--unGroupLeavesT :: NeTree a [b] -> [NeTree a b]-unGroupLeavesT (T.Node (Left v) xs)     =-    [T.Node (Left v) (unGroupLeaves xs)]-unGroupLeavesT (T.Node (Right vs) _)   =-    [T.Node (Right v) [] | v <- vs]--substGroups :: Word b => NeForest a [b] -> Sync b -> NeForest a [b]-substGroups fs ss = snd $ L.mapAccumL substGroupsT ss fs--substGroupsT :: Word b => Sync b -> NeTree a [b] -> (Sync b, NeTree a [b])-substGroupsT =-    Tr.mapAccumL f-  where-    f s (Left v)  = (s, Left v)-    f s (Right v) =-        let (v', s') = match v s-        in  (s', Right v')---- | Synchronize named entities with tokenization represented--- by the second function argument.  Of course, both arguments--- should relate to the same sentence.-moveNEs :: Word b => NeForest a b -> [b] -> NeForest a b-moveNEs ft ys-    = unGroupLeaves-    $ substGroups-        (groupForestLeaves true ft)-        (sync (leaves ft) ys)-  where-    true _ _ = True
− NLP/Nerf/Types.hs 
@@ -1,25 +0,0 @@--- | Basic types.--module NLP.Nerf.Types-( Word-, NE-, Ob-, Lb-) where--import qualified Data.Text as T-import qualified Data.Named.IOB as IOB---- | A word.-type Word = T.Text---- | A named entity.-type NE = T.Text---- | An observation consist of an index (of list type) and an actual--- observation value.-type Ob = ([Int], T.Text)---- | A label is created by encoding the named entity forest using the--- IOB method.-type Lb = IOB.Label NE
nerf.cabal view
@@ -1,5 +1,5 @@ name:               nerf-version:            0.3.0+version:            0.4.0 synopsis:           Nerf, the named entity recognition tool based on linear-chain CRFs description:     The package provides the named entity recognition (NER) tool divided into a@@ -26,6 +26,8 @@ build-type:         Simple  library+    hs-source-dirs: src+     build-depends:         base >= 4 && < 5       , containers@@ -62,6 +64,6 @@     location: https://github.com/kawu/nerf.git  executable nerf-  hs-source-dirs: ., tools+  hs-source-dirs: src, tools   main-is: nerf.hs   ghc-options: -Wall -O2 -threaded -rtsopts
+ src/NLP/Nerf.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Main module of the Nerf tool.++module NLP.Nerf+( Nerf (..)+, train+, ner+, tryOx+, module NLP.Nerf.Types+) where++import Control.Applicative ((<$>), (<*>))+import Data.Binary (Binary, put, get)+import Data.Foldable (foldMap)+import Data.List (intercalate)+import qualified Data.Text as T+import qualified Data.Text.Lazy.IO as L++import Text.Named.Enamex (parseEnamex)+import qualified Data.Named.Tree as N+import qualified Data.Named.IOB as IOB++import Numeric.SGD (SgdArgs)+import qualified Data.CRF.Chain1 as CRF++import NLP.Nerf.Types+import NLP.Nerf.Tokenize (tokenize, moveNEs)+import NLP.Nerf.Schema (SchemaConf, Schema, fromConf, schematize)++-- | A Nerf consists of the observation schema configuration and the CRF model.+data Nerf = Nerf+    { schemaConf    :: SchemaConf+    , crf           :: CRF.CRF Ob Lb }++instance Binary Nerf where+    put Nerf{..} = put schemaConf >> put crf+    get = Nerf <$> get <*> get++flatten :: Schema a -> N.NeForest NE Word -> CRF.SentL Ob Lb+flatten schema forest =+    [ CRF.annotate x y+    | (x, y) <- zip xs ys ]+  where+    iob = IOB.encodeForest forest+    xs = schematize schema (map IOB.word iob)+    ys = map IOB.label iob++-- | Tokenize sentence with the Nerf tokenizer.+reTokenize :: N.NeForest NE Word -> N.NeForest NE Word+reTokenize ft = +    moveNEs ft ((doTok . leaves) ft)+  where +    doTok  = map T.pack . tokenize . intercalate " "  . map T.unpack+    leaves = concatMap $ foldMap (either (const []) (:[]))++readDeep :: FilePath -> IO [N.NeForest NE Word]+readDeep path = map reTokenize . parseEnamex <$> L.readFile path++readFlat :: Schema a -> FilePath -> IO [CRF.SentL Ob Lb]+readFlat schema path = map (flatten schema) <$> readDeep path++drawSent :: CRF.SentL Ob Lb -> IO ()+drawSent sent = do+    let unDist (x, y) = (x, CRF.unDist y)+    mapM_ (print . unDist) sent+    putStrLn "" ++-- | Show results of observation extraction on the input ENAMEX file.+tryOx :: SchemaConf -> FilePath -> IO ()+tryOx cfg path = do+    input <- readFlat (fromConf cfg) path+    mapM_ drawSent input++-- | Train Nerf on the input data using the SGD method.+train+    :: SgdArgs              -- ^ Args for SGD+    -> SchemaConf           -- ^ Observation schema configuration+    -> FilePath             -- ^ Train data (ENAMEX)+    -> Maybe FilePath       -- ^ Maybe eval data (ENAMEX)+    -> IO Nerf              -- ^ Nerf with resulting codec and model+train sgdArgs cfg trainPath evalPathM = do+    let schema = fromConf cfg+        readTrain = readFlat schema trainPath+        readEvalM = evalPathM >>= \evalPath ->+            Just ([], readFlat schema evalPath)+    _crf <- CRF.train sgdArgs readTrain readEvalM CRF.presentFeats+    return $ Nerf cfg _crf++-- | Perform named entity recognition (NER) using the Nerf.+ner :: Nerf -> String -> N.NeForest NE Word+ner nerf sent =+    let ws = map T.pack . tokenize $ sent+        schema = fromConf (schemaConf nerf)+        xs = CRF.tag (crf nerf) (schematize schema ws)+    in  IOB.decodeForest [IOB.IOB w x | (w, x) <- zip ws xs]
+ src/NLP/Nerf/Dict.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Extraction utilities for various dictionary resources.++module NLP.Nerf.Dict+( extractPoliMorf+, extractPNEG+, extractNELexicon+, extractProlexbase+, extractIntTriggers+, extractExtTriggers+, module NLP.Nerf.Dict.Base+) where++import Control.Applicative ((<$>), (<*>))+import qualified Data.PoliMorf as Poli++import NLP.Nerf.Dict.Base+import NLP.Nerf.Dict.PNEG (readPNEG)+import NLP.Nerf.Dict.NELexicon (readNELexicon)+import NLP.Nerf.Dict.Prolexbase (readProlexbase)+import qualified NLP.Nerf.Dict.PNET as PNET++-- | Is it a single word entry?+atomic :: Entry -> Bool+atomic = not . isMultiWord . neOrth++-- | Extract NEs dictionary from PNEG.+extractPNEG+    :: FilePath     -- ^ Path to PNEG in the LMF format+    -> IO Dict+extractPNEG lmfPath =+    fromEntries . filter atomic <$> readPNEG lmfPath++-- | Extract NEs dictionary from NELexicon.+extractNELexicon+    :: FilePath     -- ^ Path to NELexicon+    -> IO Dict+extractNELexicon nePath =+    fromEntries . filter atomic <$> readNELexicon nePath++-- | Extract NEs dictionary from PoliMorf.+extractPoliMorf+    :: FilePath     -- ^ Path to PoliMorf+    -> IO Dict+extractPoliMorf poliPath+    = fromPairs . filter (cond . snd)+    . map ((,) <$> Poli.form <*> Poli.cat)+    <$> Poli.readPoliMorf poliPath+  where+    cond x = x /= "pospolita" && x /= ""++-- | Extract NEs dictionary from Prolexbase.+extractProlexbase+    :: FilePath     -- ^ Path to Prolexbase+    -> IO Dict+extractProlexbase proPath = do+    fromEntries . filter atomic <$> readProlexbase proPath++-- | Extract internal triggers from PNET dictionary.+extractIntTriggers+    :: FilePath     -- ^ Path to PNET+    -> IO Dict+extractIntTriggers pnetPath =+    mkTriggers PNET.Internal <$> PNET.readPNET pnetPath++-- | Extract external triggers from PNET dictionary.+extractExtTriggers+    :: FilePath     -- ^ Path to PNET+    -> IO Dict+extractExtTriggers pnetPath =+    mkTriggers PNET.External <$> PNET.readPNET pnetPath++mkTriggers :: PNET.Typ -> [PNET.Entry] -> Dict+mkTriggers typ+    = fromPairs+    . filter (not . isMultiWord . fst) +    . map ((,) <$> PNET.orth <*> PNET.neTyp)+    . filter (PNET.hasTyp typ)
+ src/NLP/Nerf/Dict/Base.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE TupleSections #-}++-- | Basic types for dictionary handling. ++module NLP.Nerf.Dict.Base+(+-- * Lexicon entry+  NeType+, Form+, isMultiWord+, Entry (..)++-- * Dictionary+, Label+, DAWG+, Dict+, fromPairs+, fromEntries+, siftDict+, saveDict+, loadDict++-- * Merging dictionaries+, merge+, diff+) where++import Control.Applicative ((<$>), (<*>))+import Data.Binary (encodeFile, decodeFile)+import Data.Text.Binary ()+import qualified Data.Text as T+import qualified Data.Set as S+import qualified Data.DAWG.Static as D+import qualified Data.DAWG.Trans.Vector as D++-- | A type of named entity.+type NeType = T.Text++-- | A orthographic form.+type Form = T.Text++-- | Is the form a multiword one?+isMultiWord :: Form -> Bool+isMultiWord = (>1) . length . T.words++-- | A Named Entity entry from the LMF dictionary.+data Entry = Entry+    { neOrth :: !Form	-- ^ Orthographic form of the NE+    , neType :: !NeType -- ^ Type of the NE+    } deriving (Show, Read, Eq, Ord)++-- | Dictionary label.+type Label = T.Text++-- | A 'Dict' is a map from forms to labels.  Each form may be annotated+-- with multiple labels.  The map is represented using the directed acyclic+-- word graph.+-- type Dict = D.DAWG (S.Set Label)+type DAWG = D.DAWG D.Trans Char ()+type Dict = DAWG (S.Set Label)++-- | Construct dictionary from the list of form/label pairs.+fromPairs :: [(Form, Label)] -> Dict+fromPairs xs = D.fromListWith S.union+    [ ( T.unpack x+      , S.singleton y)+    | (x, y) <- xs ]++-- | Construct dictionary from the list of entries.+fromEntries :: [Entry] -> Dict+fromEntries = fromPairs . map ((,) <$> neOrth <*> neType)++-- | Remove dictionary entries which do not satisfy the predicate.+siftDict :: (Form -> S.Set Label -> Bool) -> Dict -> Dict+siftDict f dict = D.fromList [(k, v) | (k, v) <- D.assocs dict, f (T.pack k) v]++-- | Save the dictionary in the file.+saveDict :: FilePath -> Dict -> IO ()+saveDict = encodeFile++-- | Load the dictionary from the file.+loadDict :: FilePath -> IO Dict+loadDict = decodeFile++-- | Merge dictionary resources.+merge :: [Dict] -> Dict+merge = unionsWith S.union++-- | Replacement implementation of unionsWith while there is+-- no such function in dawg library. +unionsWith :: Ord a => (a -> a -> a) -> [DAWG a] -> DAWG a+unionsWith f = foldl (unionWith f) D.empty++-- | Replacement implementation of unionWith while there is+-- no such function in dawg library. +unionWith :: Ord a => (a -> a -> a) -> DAWG a -> DAWG a -> DAWG a+unionWith f d d' = D.fromListWith f (D.assocs d ++ D.assocs d')++-- | Differentiate labels from separate dictionaries using+-- dictionary-unique prefixes.+diff :: [Dict] -> [Dict]+diff ds =+    [ mapS (addPrefix i) `mapD` dict+    | (i, dict) <- zip [0..] ds ]++-- | Map function over the DAWG elements.+mapD :: Ord b => (a -> b) -> DAWG a -> DAWG b+mapD f d = D.fromList [(x, f y) | (x, y) <- D.assocs d]++-- | Map function over the set.+mapS :: Ord b => (a -> b) -> S.Set a -> S.Set b+mapS f s = S.fromList [f x | x <- S.toList s]++-- | Add integer prefix.+addPrefix :: Int -> T.Text -> T.Text+addPrefix = T.append . T.pack . show
+ src/NLP/Nerf/Dict/NELexicon.hs view
@@ -0,0 +1,24 @@+-- | Handling the NELexicon dictionary.++module NLP.Nerf.Dict.NELexicon+( parseNELexicon+, readNELexicon+) where++import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L++import NLP.Nerf.Dict.Base++-- | Parse the NELexicon into a list of entries.+parseNELexicon :: L.Text -> [Entry]+parseNELexicon = map parseLine . L.lines++parseLine :: L.Text -> Entry+parseLine line = case L.break (==';') line of+    (_type, _form) -> Entry (L.toStrict $ L.drop 2 _form) (L.toStrict _type)+    _   -> error $ "parseLine: invalid line \"" ++ L.unpack line ++ "\""++-- | Read the dictionary from the file.+readNELexicon :: FilePath -> IO [Entry]+readNELexicon = fmap parseNELexicon . L.readFile
+ src/NLP/Nerf/Dict/PNEG.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Parsing the Gazetteer for Polish Named Entities (used formerly within+-- the SProUT platform) in the LMF format.++module NLP.Nerf.Dict.PNEG+( parsePNEG+, readPNEG+) where++import Text.XML.PolySoup+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L++import NLP.Nerf.Dict.Base++lmfP :: XmlParser L.Text [Entry]+lmfP = true ##> lexEntryP++lexEntryP :: XmlParser L.Text [Entry]+lexEntryP = tag "LexicalEntry" `joinR` do+    many_ $ cut $ tag "feat"+    _words <- many wordP+    sense  <- senseP+    return [Entry x sense | x <- _words]++wordP :: XmlParser L.Text Form+wordP = head <$> (tag "Lemma" <|> tag "WordForm" /> featP "writtenForm")++senseP :: XmlParser L.Text NeType+senseP = head <$> (tag "Sense" //> featP "externalReference" <|> featP "label")++featP :: L.Text -> XmlParser L.Text T.Text+featP x = L.toStrict <$> cut (tag "feat" *> hasAttr "att" x *> getAttr "val")++-- | Parse the dictionary to the list of entries.+parsePNEG :: L.Text -> [Entry]+parsePNEG = parseXml lmfP++-- | Read the dictionary from the file.+readPNEG :: FilePath -> IO [Entry]+readPNEG = fmap parsePNEG . L.readFile
+ src/NLP/Nerf/Dict/PNET.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Polish Named Entity Triggers <http://zil.ipipan.waw.pl/PNET> dictionary.++module NLP.Nerf.Dict.PNET+( parsePNET+, readPNET+, Typ (..)+, hasTyp+, Entry (..)+) where++import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L++-- | Trigger type.+data Typ+    = Internal+    | External+    deriving (Show, Eq, Ord)++readTyp :: T.Text -> Typ+readTyp "int" = Internal+readTyp "ext" = External+readTyp x     = error $ "readTyp: typ " ++ T.unpack x ++ " unknown"++-- | PNET entry.+data Entry = Entry+    { orth      :: T.Text+    , base      :: T.Text+    , tag       :: T.Text+    , typ       :: Typ+    , neTyp     :: T.Text+    , example   :: T.Text }++-- | Does entry represents a trigger of the given type?+hasTyp :: Typ -> Entry -> Bool+hasTyp x = (==x) . typ++parseLine :: L.Text -> Entry+parseLine line = case map L.toStrict (L.split (=='\t') line) of+    [_orth, _base, _tag, _typ, _neTyp, _example] ->+        Entry _orth _base _tag (readTyp _typ) _neTyp _example+    _   -> error $ "parseLine: invalid row \"" ++ L.unpack line ++ "\""++-- | Parse dictionary into a list of entries.+parsePNET :: L.Text -> [Entry]+parsePNET = map parseLine . L.lines++-- | Read dictionary from the file.+readPNET :: FilePath -> IO [Entry]+readPNET = fmap parsePNET . L.readFile
+ src/NLP/Nerf/Dict/Prolexbase.hs view
@@ -0,0 +1,25 @@+-- | Handling Prolexbase dictionaries, both with the+-- same storage format.++module NLP.Nerf.Dict.Prolexbase+( parseProlexbase+, readProlexbase+) where++import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L++import NLP.Nerf.Dict.Base++-- | Parse dictionary into a list of entries.+parseProlexbase :: L.Text -> [Entry]+parseProlexbase = map parseLine . L.lines++parseLine :: L.Text -> Entry+parseLine row = case map L.toStrict (L.split (=='\t') row) of+    [_form, _base, _tag, _cat] -> Entry _form _cat+    _   -> error $ "parseLine: invalid row \"" ++ L.unpack row ++ "\""++-- | Read the dictionary from the file.+readProlexbase :: FilePath -> IO [Entry]+readProlexbase = fmap parseProlexbase . L.readFile
+ src/NLP/Nerf/Schema.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Observation schema blocks for Nerf.++module NLP.Nerf.Schema+( +-- * Types+  Ox+, Schema+, void+, sequenceS_++-- * Usage+, schematize++-- ** Configuration+, Body (..)+, Entry+, entry+, entryWith+, SchemaConf (..)+, nullConf+, defaultConf+, fromConf++-- ** Schema blocks+, Block+, fromBlock+, orthB+, splitOrthB+, lowPrefixesB+, lowSuffixesB+, lemmaB+, shapeB+, packedB+, shapePairB+, packedPairB+, dictB+) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (forM_, join)+import Data.Maybe (maybeToList)+import Data.Binary (Binary, put, get)+import qualified Data.Char as C+import qualified Data.Set as S+import qualified Data.Vector as V+import qualified Data.Text as T+import qualified Data.DAWG.Static as D++import qualified Data.CRF.Chain1 as CRF+import qualified Control.Monad.Ox as Ox+import qualified Control.Monad.Ox.Text as Ox++import NLP.Nerf.Types+import NLP.Nerf.Dict (Dict)++-- | The Ox monad specialized to word token type and text observations.+type Ox a = Ox.Ox Word T.Text a++-- | A schema is a block of the Ox computation performed within the+-- context of the sentence and the absolute sentence position.+type Schema a = V.Vector Word -> Int -> Ox a++-- | A dummy schema block.+void :: a -> Schema a+void x _ _ = return x++-- | Sequence the list of schemas (or blocks) and discard individual values.+sequenceS_ :: [V.Vector Word -> a -> Ox b] -> V.Vector Word -> a -> Ox ()+sequenceS_ xs sent =+    let ys = map ($sent) xs+    in  \k -> sequence_ (map ($k) ys)++-- | Record structure of the basic observation types.+data BaseOb = BaseOb+    { orth          :: Int -> Maybe T.Text+    , lowOrth       :: Int -> Maybe T.Text }++-- | Construct the 'BaseOb' structure given the sentence.+mkBaseOb :: V.Vector Word -> BaseOb+mkBaseOb sent = BaseOb+    { orth      = _orth+    , lowOrth   = _lowOrth }+  where+    at          = Ox.atWith sent+    _orth       = (id `at`)+    _lowOrth i  = T.toLower <$> _orth i++-- | A block is a chunk of the Ox computation performed within the+-- context of the sentence and the list of absolute sentence positions.+type Block a = V.Vector Word -> [Int] -> Ox a++-- | Transform the block to the schema depending on the list of+-- relative sentence positions.+fromBlock :: Block a -> [Int] -> Schema a+fromBlock blk xs sent =+    let blkSent = blk sent+    in  \k -> blkSent [x + k | x <- xs]++-- | Orthographic form at the current position.+orthB :: Block ()+orthB sent = \ks ->+    let orthOb = Ox.atWith sent id+    in  mapM_ (Ox.save . orthOb) ks++-- | Orthographic form split into two observations: the lowercased form and+-- the original form (only when different than the lowercased one).+splitOrthB :: Block ()+splitOrthB sent = \ks -> do+    mapM_ (Ox.save . lowOrth)    ks+    mapM_ (Ox.save . upOnlyOrth) ks+  where+    BaseOb{..}      = mkBaseOb sent+    upOnlyOrth i    = orth i >>= \x -> case T.any C.isUpper x of+        True    -> Just x+        False   -> Nothing++-- | List of lowercased prefixes of given lengths.+lowPrefixesB :: [Int] -> Block ()+lowPrefixesB ns sent = \ks ->+    forM_ ks $ \i ->+        mapM_ (Ox.save . lowPrefix i) ns+  where+    BaseOb{..}      = mkBaseOb sent+    lowPrefix i j   = Ox.prefix j =<< lowOrth i++-- | List of lowercased suffixes of given lengths.+lowSuffixesB :: [Int] -> Block ()+lowSuffixesB ns sent = \ks ->+    forM_ ks $ \i ->+        mapM_ (Ox.save . lowSuffix i) ns+  where+    BaseOb{..}      = mkBaseOb sent+    lowSuffix i j   = Ox.suffix j =<< lowOrth i++-- | Lemma substitute parametrized by the number specifying the span+-- over which lowercased prefixes and suffixes will be 'Ox.save'd.+-- For example, @lemmaB 2@ will take affixes of lengths @0, -1@ and @-2@+-- on account.+lemmaB :: Int -> Block ()+lemmaB n sent = \ks -> do+    mapM_ lowLemma ks+  where+    BaseOb{..}      = mkBaseOb sent+    lowPrefix i j   = Ox.prefix j =<< lowOrth i+    lowSuffix i j   = Ox.suffix j =<< lowOrth i+    lowLemma i = Ox.group $ do+        mapM_ (Ox.save . lowPrefix i) [0, -1 .. -n]+        mapM_ (Ox.save . lowSuffix i) [0, -1 .. -n]++-- | Shape of the word.+shapeB :: Block ()+shapeB sent = \ks -> do+    mapM_ (Ox.save . shape) ks+  where+    BaseOb{..}      = mkBaseOb sent+    shape i         = Ox.shape <$> orth i++-- | Packed shape of the word.+packedB :: Block ()+packedB sent = \ks -> do+    mapM_ (Ox.save . shapeP) ks+  where+    BaseOb{..}      = mkBaseOb sent+    shape i         = Ox.shape <$> orth i+    shapeP i        = Ox.pack <$> shape i++-- -- | Shape and packed shape of the word.+-- shapeAndPackedB :: Block ()+-- shapeAndPackedB sent = \ks -> do+--     mapM_ (Ox.save . shape)  ks+--     mapM_ (Ox.save . shapeP) ks+--   where+--     BaseOb{..}      = mkBaseOb sent+--     shape i         = Ox.shape <$> orth i+--     shapeP i        = Ox.pack <$> shape i++-- | Combined shapes of two consecutive (at @k-1@ and @k@ positions) words.+shapePairB :: Block ()+shapePairB sent = \ks ->+    forM_ ks $ \i -> do+        Ox.save $ link <$> shape  i <*> shape  (i - 1)+  where+    BaseOb{..}      = mkBaseOb sent+    shape i         = Ox.shape <$> orth i+    link x y        = T.concat [x, "-", y]++-- | Combined packed shapes of two consecutive (at @k-1@ and @k@ positions)+-- words.+packedPairB :: Block ()+packedPairB sent = \ks ->+    forM_ ks $ \i -> do+        Ox.save $ link <$> shapeP i <*> shapeP (i - 1)+  where+    BaseOb{..}      = mkBaseOb sent+    shape i         = Ox.shape <$> orth i+    shapeP i        = Ox.pack <$> shape i+    link x y        = T.concat [x, "-", y]++-- | Plain dictionary search determined with respect to the list of+-- relative positions.+dictB :: Dict -> Block ()+dictB dict sent = \ks -> do+    mapM_ (Ox.saves . searchDict) ks+  where+    BaseOb{..}      = mkBaseOb sent+    searchDict i    = join . maybeToList $+        S.toList <$> (orth i >>= flip D.lookup dict . T.unpack)++-- | Body of configuration entry.+data Body a = Body {+    -- | Range argument for the schema block. +      range :: [Int]+    -- | Additional arguments for the schema block.+    , args  :: a }+    deriving (Show)++instance Binary a => Binary (Body a) where+    put Body{..} = put range >> put args+    get = Body <$> get <*> get++-- | Maybe entry.+type Entry a = Maybe (Body a)++-- | Entry with additional arguemnts.+entryWith :: a -> [Int] -> Entry a+entryWith v xs = Just (Body xs v)++-- | Maybe entry with additional arguemnts.+entryWith'Mb :: Maybe a -> [Int] -> Entry a+entryWith'Mb (Just v) xs = Just (Body xs v)+entryWith'Mb Nothing _   = Nothing++-- | Plain entry with no additional arugments.+entry :: [Int] -> Entry ()+entry = entryWith ()++-- | Configuration of the schema.  All configuration elements specify the+-- range over which a particular observation type should be taken on account.+-- For example, the @[-1, 0, 2]@ range means that observations of particular+-- type will be extracted with respect to previous (@k - 1@), current (@k@)+-- and after the next (@k + 2@) positions when identifying the observation+-- set for position @k@ in the input sentence.+data SchemaConf = SchemaConf {+    -- | The 'orthB' schema block.+      orthC             :: Entry ()+    -- | The 'splitOrthB' schema block.+    , splitOrthC        :: Entry ()+    -- | The 'lowPrefixesB' schema block.  The first list of ints+    -- represents lengths of prefixes.+    , lowPrefixesC      :: Entry [Int]+    -- | The 'lowSuffixesB' schema block.  The first list of ints+    -- represents lengths of suffixes.+    , lowSuffixesC      :: Entry [Int]+    -- | The 'lemmaB' schema block.+    , lemmaC            :: Entry Int+    -- | The 'shapeB' schema block.+    , shapeC            :: Entry ()+    -- | The 'packedB' schema block.+    , packedC           :: Entry ()+    -- | The 'shapePairB' schema block.+    , shapePairC        :: Entry ()+    -- | The 'packedPairB' schema block.+    , packedPairC       :: Entry ()+    -- | Dictionaries of NEs ('dictB' schema block).+    , dictC             :: Entry [Dict]+    -- | Dictionary of internal triggers.+    , intTrigsC         :: Entry Dict+    -- | Dictionary of external triggers.+    , extTrigsC         :: Entry Dict+    } deriving (Show)++instance Binary SchemaConf where+    put SchemaConf{..} = do+        put orthC+        put splitOrthC+        put lowPrefixesC+        put lowSuffixesC+        put lemmaC+        put shapeC+        put packedC+        put shapePairC+        put packedPairC+        put dictC+        put intTrigsC+        put extTrigsC+    get = SchemaConf+        <$> get <*> get <*> get <*> get+        <*> get <*> get <*> get <*> get+        <*> get <*> get <*> get <*> get++-- | Null configuration of the observation schema.+nullConf :: SchemaConf+nullConf = SchemaConf+    Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing+    Nothing Nothing Nothing Nothing++-- | Default configuration of the observation schema.+defaultConf+    :: [Dict]       -- ^ Named Entity dictionaries+    -> Maybe Dict   -- ^ Dictionary of internal triggers+    -> Maybe Dict   -- ^ Dictionary of external triggers+    -> IO SchemaConf+defaultConf neDicts intDict extDict = do+    return $ SchemaConf+        { orthC         = Nothing+        , splitOrthC    = entry                 [-1, 0]+        , lowPrefixesC  = Nothing+        , lowSuffixesC  = entryWith [2, 3, 4]   [0]+        , lemmaC        = entryWith 3           [-1, 0]+        , shapeC        = entry                 [-1, 0]+        , packedC       = entry                 [-1, 0]+        , shapePairC    = entry                 [0]+        , packedPairC   = entry                 [0]+        , dictC         = entryWith neDicts     [-1, 0]+        , intTrigsC     = entryWith'Mb intDict  [0]+        , extTrigsC     = entryWith'Mb extDict  [-1] }++mkArg0 :: Block () -> Entry () -> Schema ()+mkArg0 blk (Just x) = fromBlock blk (range x)+mkArg0 _   Nothing  = void ()++mkArg1 :: (a -> Block ()) -> Entry a -> Schema ()+mkArg1 blk (Just x) = fromBlock (blk (args x)) (range x)+mkArg1 _   Nothing  = void ()++mkArgs1 :: (a -> Block ()) -> Entry [a] -> Schema ()+mkArgs1 blk (Just x) = sequenceS_+    [ fromBlock+        (blk dict)+        (range x)+    | dict <- args x ]+mkArgs1 _   Nothing  = void ()++-- | Build the schema based on the configuration.+fromConf :: SchemaConf -> Schema ()+fromConf SchemaConf{..} = sequenceS_+    [ mkArg0 orthB orthC+    , mkArg0 splitOrthB splitOrthC+    , mkArg1 lowPrefixesB lowPrefixesC+    , mkArg1 lowSuffixesB lowSuffixesC+    , mkArg1 lemmaB lemmaC+    , mkArg0 shapeB shapeC+    , mkArg0 packedB packedC+    , mkArg0 shapePairB shapePairC+    , mkArg0 packedPairB packedPairC+    , mkArgs1 dictB dictC+    , mkArg1 dictB intTrigsC+    , mkArg1 dictB extTrigsC ]++-- | Use the schema to extract observations from the sentence.+schematize :: Schema a -> [Word] -> CRF.Sent Ob+schematize schema xs =+    map (S.fromList . Ox.execOx . schema v) [0 .. n - 1]+  where+    v = V.fromList xs+    n = V.length v
+ src/NLP/Nerf/Tokenize.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++-- | The module implements the tokenization used within Nerf+-- and some other tokenization-related stuff.++module NLP.Nerf.Tokenize+(+-- * Tokenization+  tokenize+-- * Synchronization+, Word (..)+, moveNEs+) where++import Control.Monad ((>=>))+import Data.Foldable (foldMap)+import qualified Data.Char as Char+import qualified Data.List as L+import qualified Data.Tree as T+import qualified Data.Traversable as Tr+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LazyText+import qualified NLP.Tokenize as Tok++import Data.Named.Tree (NeForest, NeTree, groupForestLeaves)++---------------------------+-- Tokenization definition.+---------------------------++-- | Default tokenizator.+defaultTokenizer :: Tok.Tokenizer+defaultTokenizer+    =   Tok.whitespace+    >=> Tok.uris+    >=> Tok.punctuation++-- | Tokenize sentence using the default tokenizer.+tokenize :: String -> [String]+tokenize = Tok.run defaultTokenizer++---------------------------------------------------------------+-- Synchronizing named entities with new sentence tokenization.+---------------------------------------------------------------++-- | A class of objects with size.+class Word a where+    word :: a -> String++instance Word String where+    word = id++instance Word Text.Text where+    word = Text.unpack++instance Word LazyText.Text where+    word = LazyText.unpack++essence :: Word a => a -> Int+essence = length . filter (not . Char.isSpace) . word+{-# INLINE essence #-}++-- | Syncronization between two sentences.  Each (xs, ys) pair represents+-- tokens from the two input sentences which corresponds to each other.+type Sync a b = [([a], [b])]++-- | Synchronize two tokenizations of the sentence.+sync :: (Word a, Word b) => [a] -> [b] -> Sync a b+sync = sync' 0++sync' :: (Word a, Word b) => Int -> [a] -> [b] -> Sync a b+sync' r (x:xs) (y:ys)+    | n + r == m    = ([x], [y])    : sync' 0       xs    ys+    | n + r  < m    = join x        $ sync' (n + r) xs (y:ys)+    | otherwise     = swap . join y $ sync' (m - r) ys (x:xs)+  where+    n = essence x+    m = essence y+    join l ((ls, rs) : ps)  = (l:ls, rs) : ps+    join _ []               = error "sync'.join: bad arguments"+    swap ((ls, rs) : ps)    = (rs, ls) : swap ps+    swap []                 = []+sync' 0 [] [] = []+sync' _ _  _  = error "sync': bad arguments"++-- | Match the `Sync` with the given list, return the matching result+-- (snd elements of the `Sync` list) and the rest of the `Sync` list.+match :: (Word a, Word b) => [a] -> Sync a b -> ([b], Sync a b)+match xs ss =+    let (sl, sr) = splitAcc isMatch 0 ss+    in  (concatMap snd sl, sr)+  where+    n = sum (map essence xs)+    isMatch r (ys, _)+        | m + r < n     = (m + r, False)+        | m + r == n    = (m + r, True)+        | otherwise     = error "match.isMatch: no match"+      where+        m = sum (map essence ys)++-- | Split the list with the help of the accumulating function.+splitAcc :: (acc -> a -> (acc, Bool)) -> acc -> [a] -> ([a], [a])+splitAcc _ _ [] = ([], [])+splitAcc f acc (x:xs)+    | cond      = ([x], xs)+    | otherwise = join x (splitAcc f acc' xs)+  where+    (acc', cond) = f acc x+    join y (ys, zs) = (y:ys, zs)++-- | List forest leaves.+leaves :: NeForest a b -> [b]+leaves = concatMap $ foldMap (either (const []) (:[]))++unGroupLeaves :: NeForest a [b] -> NeForest a b+unGroupLeaves = concatMap unGroupLeavesT++unGroupLeavesT :: NeTree a [b] -> [NeTree a b]+unGroupLeavesT (T.Node (Left v) xs)     =+    [T.Node (Left v) (unGroupLeaves xs)]+unGroupLeavesT (T.Node (Right vs) _)   =+    [T.Node (Right v) [] | v <- vs]++substGroups :: (Word b, Word c) => NeForest a [b] -> Sync b c -> NeForest a [c]+substGroups fs ss = snd $ L.mapAccumL substGroupsT ss fs++substGroupsT+    :: (Word b, Word c)+    => Sync b c -> NeTree a [b]+    -> (Sync b c, NeTree a [c])+substGroupsT =+    Tr.mapAccumL f+  where+    f s (Left v)  = (s, Left v)+    f s (Right v) =+        let (v', s') = match v s+        in  (s', Right v')++-- | Synchronize named entities with tokenization represented+-- by the second function argument.  Of course, both arguments+-- should relate to the same sentence.+moveNEs :: (Word b, Word c) => NeForest a b -> [c] -> NeForest a c+moveNEs ft ys+    = unGroupLeaves+    $ substGroups+        (groupForestLeaves true ft)+        (sync (leaves ft) ys)+  where+    true _ _ = True
+ src/NLP/Nerf/Types.hs view
@@ -0,0 +1,25 @@+-- | Basic types.++module NLP.Nerf.Types+( Word+, NE+, Ob+, Lb+) where++import qualified Data.Text as T+import qualified Data.Named.IOB as IOB++-- | A word.+type Word = T.Text++-- | A named entity.+type NE = T.Text++-- | An observation consist of an index (of list type) and an actual+-- observation value.+type Ob = ([Int], T.Text)++-- | A label is created by encoding the named entity forest using the+-- IOB method.+type Lb = IOB.Label NE
tools/nerf.hs view
@@ -14,14 +14,12 @@ import Data.Text.Binary () import Text.Named.Enamex (showForest) import qualified Numeric.SGD as SGD-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.Static as D  import NLP.Nerf (train, ner, tryOx) import NLP.Nerf.Schema (defaultConf)-import NLP.Nerf.Tokenize (tokenize) import NLP.Nerf.Dict     ( extractPoliMorf, extractPNEG, extractNELexicon, extractProlexbase     , extractIntTriggers, extractExtTriggers, Dict )@@ -147,7 +145,7 @@     nerf  <- decodeFile inNerf     input <- readRaw dataPath     forM_ input $ \sent -> do-        let forest = ner nerf sent+        let forest = ner nerf (L.unpack sent)         L.putStrLn (showForest forest)  exec nerfArgs@Ox{..} = do@@ -157,12 +155,5 @@         intDict extDict     tryOx cfg dataPath --- | Prepare input data: divide it into a list of sentences and tokenize--- each sentence using the default tokenizer.-parseRaw :: L.Text -> [[T.Text]]-parseRaw =-    let doTok = map T.pack . tokenize . L.unpack-    in  map doTok . L.lines--readRaw :: FilePath -> IO [[T.Text]]-readRaw = fmap parseRaw . L.readFile+readRaw :: FilePath -> IO [L.Text]+readRaw = fmap L.lines . L.readFile