concraft 0.4.0 → 0.5.0

raw patch · 13 files changed

+580/−735 lines, 13 filesdep +aesondep +bytestringdep +transformersdep −cmdargsdep ~monad-oxdep ~tagset-positionalPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, bytestring, transformers, zlib

Dependencies removed: cmdargs

Dependency ranges changed: monad-ox, tagset-positional

API changes (from Hackage documentation)

Files

• concraft.cabal +16/−17
• src/NLP/Concraft.hs +132/−61
• src/NLP/Concraft/Analysis.hs +100/−0
• src/NLP/Concraft/Disamb.hs +44/−75
• src/NLP/Concraft/Disamb/Positional.hs +0/−11
• src/NLP/Concraft/Format.hs +0/−44
• src/NLP/Concraft/Format/Plain.hs +0/−208
• src/NLP/Concraft/Format/Temp.hs +29/−0
• src/NLP/Concraft/Guess.hs +42/−79
• src/NLP/Concraft/Morphosyntax.hs +111/−32
• src/NLP/Concraft/Morphosyntax/Align.hs +79/−0
• src/NLP/Concraft/Schema.hs +27/−102
• tools/concraft.hs +0/−106

@@ -1,9 +1,9 @@ name:               concraft-version:            0.4.0-synopsis:           Morphosyntactic tagging tool based on constrained CRFs+version:            0.5.0+synopsis:           Morphological disambiguation based on constrained CRFs description:-    A morphosyntactic tagging tool based on constrained conditional-    random fields.+    A morphological disambiguation library based on+    constrained conditional random fields. license:            BSD3 license-file:       LICENSE cabal-version:      >= 1.6@@ -23,42 +23,41 @@       , array       , containers       , binary+      , bytestring       , text       , text-binary >= 0.1 && < 0.2       , vector       , vector-binary       , crf-chain1-constrained >= 0.1.2 && < 0.2-      , monad-ox >= 0.2 && < 0.3+      , monad-ox >= 0.3 && < 0.4       , sgd >= 0.2.2 && < 0.3-      , tagset-positional >= 0.2 && < 0.3+      , tagset-positional >= 0.3 && < 0.4       , crf-chain2-generic >= 0.3 && < 0.4       , monad-codec >= 0.2 && < 0.3       , data-lens+      , transformers       , comonad-transformers       , temporary+      , aeson >= 0.6 && < 0.7+      , zlib >= 0.5 && < 0.6      exposed-modules:         NLP.Concraft-      , NLP.Concraft.Guess-      , NLP.Concraft.Disamb       , NLP.Concraft.Morphosyntax-      , NLP.Concraft.Format-      , NLP.Concraft.Format.Plain+      , NLP.Concraft.Analysis       , NLP.Concraft.Schema+      , NLP.Concraft.Guess+      , NLP.Concraft.Disamb      other-modules:         NLP.Concraft.Disamb.Tiered       , NLP.Concraft.Disamb.Positional+      , NLP.Concraft.Morphosyntax.Align+      , NLP.Concraft.Format.Temp +     ghc-options: -Wall -O2  source-repository head     type: git     location: https://github.com/kawu/concraft.git--executable concraft-    build-depends:-        cmdargs-    hs-source-dirs: src, tools-    main-is: concraft.hs    -    ghc-options: -Wall -O2 -threaded -rtsopts

@@ -2,98 +2,169 @@  module NLP.Concraft (--- * Types+-- * Model    Concraft (..)+, saveModel+, loadModel  -- * Tagging , tag-, tagSent-, tagDoc  -- * Training , train ) where -import System.IO (hClose)-import Control.Applicative ((<$>), (<*>))-import Data.Foldable (Foldable)-import Data.Binary (Binary, put, get)-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L+import           System.IO (hClose)+import           Control.Applicative ((<$>), (<*>))+import           Control.Monad (when)+import           Data.Binary (Binary, put, get)+import qualified Data.Binary as Binary+import           Data.Aeson+import           Data.Maybe (fromJust) import qualified System.IO.Temp as Temp+import qualified Data.ByteString.Lazy as BL+import qualified Codec.Compression.GZip as GZip -import qualified NLP.Concraft.Morphosyntax as Mx-import qualified NLP.Concraft.Format as F+import           NLP.Concraft.Morphosyntax+import           NLP.Concraft.Analysis+import           NLP.Concraft.Format.Temp+import qualified Data.Tagset.Positional as P import qualified NLP.Concraft.Guess as G import qualified NLP.Concraft.Disamb as D ++---------------------+-- Model+---------------------+++modelVersion :: String+modelVersion = "0.5"++ -- | Concraft data. data Concraft = Concraft-    { guessNum      :: Int-    , guesser       :: G.Guesser F.Tag+    { tagset        :: P.Tagset+    , guessNum      :: Int+    , guesser       :: G.Guesser P.Tag     , disamb        :: D.Disamb } + instance Binary Concraft where     put Concraft{..} = do+        put modelVersion+        put tagset         put guessNum         put guesser         put disamb-    get = Concraft <$> get <*> get <*> get+    get = do+        comp <- get     +        when (comp /= modelVersion) $ error $+            "Incompatible model version: " ++ comp +++            ", expected: " ++ modelVersion+        Concraft <$> get <*> get <*> get <*> get --- | Perform disambiguation preceded by context-sensitive guessing.-tag :: Concraft -> Mx.Sent F.Tag -> [F.Tag]-tag Concraft{..} sent-    = D.disamb disamb-    . G.include sent -    . G.guess guessNum guesser -    $ sent --- | Tag the sentence.-tagSent :: F.Sent s w -> Concraft -> s -> s-tagSent sentH Concraft{..}-    = D.disambSent sentH disamb-    . G.guessSent  sentH guessNum guesser+-- | Save model in a file.  Data is compressed using the gzip format.+saveModel :: FilePath -> Concraft -> IO ()+saveModel path = BL.writeFile path . GZip.compress . Binary.encode --- | Tag document.-tagDoc :: Functor f => F.Doc f s w -> Concraft -> L.Text -> L.Text-tagDoc F.Doc{..} concraft =-    let onSent = tagSent sentHandler concraft-    in  showDoc . fmap onSent . parseDoc +-- | Load model from a file.+loadModel :: FilePath -> IO Concraft+loadModel path = do+    x <- Binary.decode . GZip.decompress <$> BL.readFile path+    x `seq` return x+++---------------------+-- Tagging+---------------------+++-- | Tag sentence using the model.  In your code you should probably+-- use your analysis function, translate results into a container of+-- `Sent`ences, evaluate `tagSent` on each sentence and embed the+-- tagging results into morphosyntactic structure of your own.+tag :: Word w => Concraft -> Sent w P.Tag -> [P.Tag]+tag Concraft{..} = D.disamb disamb . G.guessSent guessNum guesser+++---------------------+-- Training+---------------------++-- INFO: We take an input dataset as a list, since it is read only once.+ -- | Train guessing and disambiguation models. train-    :: (Functor f, Foldable f)-    => F.Doc f s w      -- ^ Document format handler+    :: (Word w, FromJSON w, ToJSON w)+    => P.Tagset         -- ^ Tagset+    -> Analyse w P.Tag  -- ^ Analysis function     -> Int              -- ^ Numer of guessed tags for each word      -> G.TrainConf      -- ^ Guessing model training configuration     -> D.TrainConf      -- ^ Disambiguation model training configuration-    -> FilePath         -- ^ Training file-    -> Maybe FilePath   -- ^ Maybe eval file-    -> IO Concraft      -- ^ Resultant models-train format guessNum guessConf disambConf trainPath evalPath'Maybe = do-    putStrLn "\n===== Train guessing model ====\n"-    guesser <- G.train format guessConf trainPath evalPath'Maybe-    let withGuesser = guessFile format guessNum guesser-    withGuesser "train" (Just trainPath) $ \(Just trainPathG) ->-      withGuesser "eval"   evalPath'Maybe  $ \evalPathG'Maybe  -> do-        putStrLn "\n===== Train disambiguation model ====\n"-        disamb <- D.train format disambConf trainPathG evalPathG'Maybe-        return $ Concraft guessNum guesser disamb+    -> [SentO w P.Tag]  -- ^ Training data+    -> Maybe [SentO w P.Tag]  -- ^ Maybe evaluation data+    -> IO Concraft+train tagset ana guessNum guessConf disambConf train0 eval0 = do+    putStrLn "\n===== Reanalysis ====="+    trainR <- reAnaPar tagset ana train0+    evalR  <- case eval0 of+            Just ev -> Just <$> reAnaPar tagset ana ev+            Nothing -> return Nothing+    withTemp tagset "train" trainR $ \trainR'IO -> do+    withTemp' tagset "eval" evalR  $ \evalR'IO  -> do -guessFile-    :: Functor f-    => F.Doc f s w              -- ^ Document format handler-    -> Int                      -- ^ Numer of guessed tags for each word-    -> G.Guesser F.Tag          -- ^ Guesser-    -> String                   -- ^ Template for temporary file name-    -> Maybe FilePath           -- ^ File to guess-    -> (Maybe FilePath -> IO a) -- ^ Handler+    putStrLn "\n===== Train guessing model ====="+    guesser <- do+        tr <- trainR'IO+        ev <- evalR'IO+        G.train guessConf tr ev+    trainG <-       map (G.guessSent guessNum guesser)  <$> trainR'IO+    evalG  <- fmap (map (G.guessSent guessNum guesser)) <$> evalR'IO++    putStrLn "\n===== Train disambiguation model ====="+    disamb <- D.train disambConf trainG evalG+    return $ Concraft tagset guessNum guesser disamb+++---------------------+-- Temporary storage+---------------------+++-- | Store dataset on a disk and run a handler on a list which is read+-- lazily from the disk.  A temporary file will be automatically+-- deleted after the handler is done.+withTemp+    :: (FromJSON w, ToJSON w)+    => P.Tagset+    -> String                       -- ^ Template for `Temp.withTempFile`+    -> [Sent w P.Tag]               -- ^ Input dataset+    -> (IO [Sent w P.Tag] -> IO a)  -- ^ Handler     -> IO a-guessFile _ _ _ _ Nothing handler = handler Nothing-guessFile format guessNum gsr tmpl (Just path) handler =-    Temp.withTempFile "." tmpl $ \tmpPath tmpHandle -> do-        inp <- L.readFile path-        let out = G.guessDoc format guessNum gsr inp-        hClose tmpHandle-        L.writeFile tmpPath out-        handler (Just tmpPath)+withTemp tagset tmpl xs handler =+    withTemp' tagset tmpl (Just xs) (handler . fmap fromJust)+++-- | Similar to `withTemp` but on a `Maybe` dataset.+--+-- Store dataset on a disk and run a handler on a list which is read+-- lazily from the disk.  A temporary file will be automatically+-- deleted after the handler is done.+withTemp'+    :: (FromJSON w, ToJSON w)+    => P.Tagset+    -> String+    -> Maybe [Sent w P.Tag]+    -> (IO (Maybe [Sent w P.Tag]) -> IO a)+    -> IO a+withTemp' tagset tmpl (Just xs) handler =+  Temp.withTempFile "." tmpl $ \tmpPath tmpHandle -> do+    hClose tmpHandle+    let txtSent = mapSent $ P.showTag tagset+        tagSent = mapSent $ P.parseTag tagset+    writePar tmpPath $ map txtSent xs+    handler (Just . map tagSent <$> readPar tmpPath)+withTemp' _ _ Nothing handler = handler (return Nothing)

@@ -0,0 +1,100 @@+-- | Morphosyntactic analysis utilities.+--+-- See `reAnaSent` function for a description of how reanalsis is performed.+-- At some point it would be nice to change the entire process so that+-- sentence-level segmentation is also taken from the reanalysed data.+++module NLP.Concraft.Analysis+(+-- * Analysis+  Analyse+-- * Reanalysis+, reAnaSent+, reAnaPar+) where+++import System.IO.Unsafe (unsafeInterleaveIO)+import qualified Data.Text.Lazy as L++import           NLP.Concraft.Morphosyntax+import qualified Data.Tagset.Positional as P+import qualified NLP.Concraft.Morphosyntax.Align as A+++---------------------+-- Analysis+---------------------+++-- | An analyser performs word-level segmentation and morphological analysis.+type Analyse w t = L.Text -> IO (Sent w t)+++---------------------+-- Reanalysis+---------------------+++-- | Reanalyse sentence.+--+-- From the reference sentence the function takes:+--+--   * Word-level segmentation+--+--   * Chosen interpretations (tags)+--+-- From the reanalysed sentence the function takes:+--+--   * Potential interpretations+--+reAnaSent :: Word w => P.Tagset -> Analyse w P.Tag+          -> SentO w P.Tag -> IO (Sent w P.Tag)+reAnaSent tagset ana sent = do+    let gold = segs sent+    reana <- ana (orig sent)+    return $ A.sync tagset gold reana+++-- | Reanalyse paragraph.+reAnaPar :: Word w => P.Tagset -> Analyse w P.Tag+         -> [SentO w P.Tag] -> IO [Sent w P.Tag]+reAnaPar tagset ana = lazyMapM (reAnaSent tagset ana)+++lazyMapM :: (a -> IO b) -> [a] -> IO [b]+lazyMapM f (x:xs) = do+    y <- f x+    ys <- unsafeInterleaveIO $ lazyMapM f xs+    return (y:ys)+lazyMapM _ [] = return []+++---------------------+-- Junk+---------------------+++-- -- | Reanalyse paragraph.+-- reanalyse :: Word w => P.Tagset -> Analyse w P.Tag+--           -> [SentO w P.Tag] -> [Sent w P.Tag]+-- reanalyse tagset ana xs = chunk+--     -- We have to take sentence lengths from the reference corpus because+--     -- token-level segmentation is also taken from the reference corpus+--     -- (in case of inconsistencies between the two corpora).+--     (map length gold)+--     (A.sync tagset (concat gold) (concat reana))+--   where+--     gold  = map segs xs+--     reana = ana . L.concat $ map orig xs+--+--+-- -- | Divide the list into a list of chunks given the list of+-- -- lengths of individual chunks.+-- chunk :: [Int] -> [a] -> [[a]]+-- chunk (n:ns) xs = +--     let (first, rest) = splitAt n xs +--     in  first : chunk ns rest+-- chunk [] [] = []+-- chunk [] _  = error "chunk: absurd"

@@ -9,12 +9,11 @@ -- * Tiers , P.Tier (..) , P.Atom (..)-, P.tiersDefault  -- * Disambiguation , disamb+, include , disambSent-, disambDoc  -- * Training , TrainConf (..)@@ -24,28 +23,24 @@ import Control.Applicative ((<$>), (<*>)) import Data.Maybe (fromJust) import Data.List (find)-import Data.Foldable (Foldable, foldMap) import Data.Binary (Binary, put, get) import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Vector as V-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L  import qualified Control.Monad.Ox as Ox import qualified Data.CRF.Chain2.Generic.External as CRF  import NLP.Concraft.Schema hiding (schematize)-import qualified NLP.Concraft.Morphosyntax as Mx-import qualified NLP.Concraft.Format as F+import qualified NLP.Concraft.Morphosyntax as X  import qualified NLP.Concraft.Disamb.Tiered as Tier import qualified NLP.Concraft.Disamb.Positional as P-import qualified Data.Tagset.Positional as TP+import qualified Data.Tagset.Positional as T import qualified Numeric.SGD as SGD  -- | Schematize the input sentence with according to 'schema' rules.-schematize :: Schema t a -> Mx.Sent t -> CRF.Sent Ob t+schematize :: Schema w t a -> X.Sent w t -> CRF.Sent Ob t schematize schema sent =     [ CRF.mkWord (obs i) (lbs i)     | i <- [0 .. n - 1] ]@@ -53,111 +48,85 @@     v = V.fromList sent     n = V.length v     obs = S.fromList . Ox.execOx . schema v-    lbs i = Mx.interpsSet w+    lbs i = X.interpsSet w         where w = v V.! i  -- | A disambiguation model. data Disamb = Disamb-    { tagset        :: TP.Tagset-    , tiers         :: [P.Tier]+    { tiers         :: [P.Tier]     , schemaConf    :: SchemaConf     , crf           :: Tier.CRF Ob P.Atom }  instance Binary Disamb where-    put Disamb{..} = put tagset >> put tiers >> put schemaConf >> put crf-    get = Disamb <$> get <*> get <*> get <*> get+    put Disamb{..} = put tiers >> put schemaConf >> put crf+    get = Disamb <$> get <*> get <*> get  -- | Unsplit the complex tag (assuming, that it is one -- of the interpretations of the word).-unSplit :: Eq t => (r -> t) -> Mx.Word r -> t -> r-unSplit split' word x = fromJust $ find ((==x) . split') (Mx.interps word)---- -- | CRF training function.--- type TrainCRF o t c---     =  IO [CRF.SentL o t]           -- ^ Training data 'IO' action---     -> Maybe (IO [CRF.SentL o t])   -- ^ Maybe evalation data---     -> IO c                         -- ^ Resulting model--- --- -- | CRF tagging function.--- type TagCRF o t = CRF.Sent o t -> [t]+unSplit :: Eq t => (r -> t) -> X.Seg w r -> t -> r+unSplit split' word x = fromJust $ find ((==x) . split') (X.interps word)  -- | Perform context-sensitive disambiguation.-disamb :: Disamb -> Mx.Sent F.Tag -> [F.Tag]+disamb :: X.Word w => Disamb -> X.Sent w T.Tag -> [T.Tag] disamb Disamb{..} sent     = map (uncurry embed)     . zip sent     . Tier.tag crf     . schematize schema-    . Mx.mapSent split+    . X.mapSent split     $ sent   where     schema  = fromConf schemaConf-    split   = P.split tiers . TP.parseTag tagset+    split   = P.split tiers     embed   = unSplit split --- | Tag the sentence.-disambSent :: F.Sent s w -> Disamb -> s -> s-disambSent F.Sent{..} dmb sent =-  flip mergeSent sent-    [ select wMap orig-    | (wMap, orig) <- zip-        (doDmb sent)-        (parseSent sent) ]+-- | Insert disambiguation results into the sentence.+include :: (X.Sent w T.Tag -> [T.Tag]) -> X.Sent w T.Tag -> X.Sent w T.Tag+include f sent =+    [ word { X.tags = tags }+    | (word, tags) <- zip sent sentTags ]   where-    F.Word{..} = wordHandler-    doDmb orig =-        let xs = map extract (parseSent orig)-        in  map (uncurry mkChoice) (zip xs (disamb dmb xs))-    mkChoice word x = Mx.mkWMap-        [ if x == y-            then (x, 1)-            else (y, 0)-        | y <- Mx.interps word ]+    sentTags = map (uncurry select) (zip (f sent) sent)+    select x word = X.mkWMap+        [ (y, if x == y then 1 else 0)+        | y <- X.interps word ] --- | Disambiguate document.-disambDoc :: Functor f => F.Doc f s w -> Disamb -> L.Text -> L.Text-disambDoc F.Doc{..} dmb =-    let onSent = disambSent sentHandler dmb-    in  showDoc . fmap onSent . parseDoc+-- | Combine `disamb` with `include`. +disambSent :: X.Word w => Disamb -> X.Sent w T.Tag -> X.Sent w T.Tag+disambSent = include . disamb  -- | Training configuration. data TrainConf = TrainConf-    { tagsetT       :: TP.Tagset-    , tiersT        :: [P.Tier]+    { tiersT        :: [P.Tier]     , schemaConfT   :: SchemaConf     , sgdArgsT      :: SGD.SgdArgs }  -- | Train disamb model. train-    :: Foldable f-    => F.Doc f s w      -- ^ Document format handler-    -> TrainConf        -- ^ Training configuration-    -> FilePath         -- ^ Training file-    -> Maybe FilePath   -- ^ Maybe eval file-    -> IO Disamb        -- ^ Resultant model-train format TrainConf{..} trainPath evalPath'Maybe = do+    :: X.Word w+    => TrainConf                        -- ^ Training configuration+    -> [X.Sent w T.Tag]                 -- ^ Training data+    -> Maybe [X.Sent w T.Tag]           -- ^ Maybe evaluation data+    -> IO Disamb                        -- ^ Resultant model+train TrainConf{..} trainData evalData'Maybe = do     crf <- Tier.train         (length tiersT)         sgdArgsT-        (schemed format schema split trainPath)-        (schemed format schema split <$> evalPath'Maybe)-    return $ Disamb tagsetT tiersT schemaConfT crf+        (retSchemed schema split trainData)+        (retSchemed schema split <$> evalData'Maybe)+    return $ Disamb tiersT schemaConfT crf   where+    retSchemed sc sp = return . schemed sc sp      schema = fromConf schemaConfT-    split  = P.split tiersT . TP.parseTag tagsetT+    split  = P.split tiersT  -- | Schematized data from the plain file.-schemed-    :: (Foldable f, Ord t)-    => F.Doc f s w -> Schema t a -> (F.Tag -> t)-    -> FilePath -> IO [CRF.SentL Ob t]-schemed F.Doc{..} schema split path =-    foldMap onSent . parseDoc <$> L.readFile path+schemed :: Ord t => Schema w t a -> (T.Tag -> t)+        -> [X.Sent w T.Tag] -> [CRF.SentL Ob t]+schemed schema split =+    map onSent   where-    F.Sent{..} = sentHandler-    F.Word{..} = wordHandler     onSent sent =-        [zip (schematize schema xs) (map mkDist xs)]-      where-        xs  = map (Mx.mapWord split . extract) (parseSent sent)-        mkDist = CRF.mkDist . M.toList . Mx.unWMap . Mx.tagWMap+        let xs  = map (X.mapSeg split) sent+            mkDist = CRF.mkDist . M.toList . X.unWMap . X.tags+        in  zip (schematize schema xs) (map mkDist xs)

@@ -9,7 +9,6 @@ , Atom (..) , select , split-, tiersDefault ) where  import Control.Applicative ((<$>), (<*>))@@ -52,13 +51,3 @@ split tiers tag =     [ select tier tag     | tier <- tiers ]---- | Default tiered tagging configuration.-tiersDefault :: [Tier]-tiersDefault =-    [tier1, tier2]-  where-    tier1 = Tier True $ S.fromList ["cas", "per"]-    tier2 = Tier False $ S.fromList-        [ "nmb", "gnd", "deg", "asp" , "ngt", "acm"-        , "acn", "ppr", "agg", "vlc", "dot" ]

@@ -1,44 +0,0 @@--- | The module provides several abstractions for representing external--- data formats.  Concraft will be able to work with any format which--- implements those abstractions.--module NLP.Concraft.Format-( Tag-, Word (..)-, Sent (..)-, Doc (..)-) where--import Prelude hiding (words, unwords)-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified NLP.Concraft.Morphosyntax as M---- | Textual representation of morphposyntactic tag.-type Tag = T.Text---- | Word handler.-data Word w = Word {-    -- | Extract information relevant for tagging.-      extract       :: w -> M.Word Tag-    -- | Select the set of morphosyntactic interpretations.-    , select        :: M.WMap Tag -> w -> w }---- | Sentence handler.-data Sent s w = Sent {-    -- | Split sentence into a list of words.-      parseSent     :: s -> [w]-    -- | Merge words with a sentence.-    , mergeSent     :: [w] -> s -> s-    -- | Words handler.-    , wordHandler   :: Word w }---- | Document format.-data Doc f s w = Doc {-    -- | Parse textual interpretations into a functor with-    -- sentence elements.-      parseDoc      :: L.Text -> f s-    -- | Show textual reprezentation of a document.-    , showDoc       :: f s -> L.Text-    -- | Sentence handler.-    , sentHandler   :: Sent s w }

@@ -1,208 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}---- | Simple format for morphosyntax representation which--- assumes that all tags have a textual representation--- with no spaces inside and that one of the tags indicates--- unknown words.--module NLP.Concraft.Format.Plain-(--- * Types-  Token (..)-, Interp (..)-, Space (..)--- * Format handler-, plainFormat--- * Parsing-, parsePlain-, parseSent--- * Printing-, showPlain-, showSent-) where--import Control.Arrow (first)-import Data.Monoid (Monoid, mappend, mconcat)-import Data.Maybe (catMaybes)-import Data.List (groupBy)-import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Builder as L--import qualified NLP.Concraft.Morphosyntax as Mx-import qualified NLP.Concraft.Format as F---- | No space, space or newline.-data Space-    = None-    | Space-    | NewLine-    deriving (Show, Eq, Ord)---- | A token.-data Token = Token-    { orth      :: T.Text-    , space     :: Space-    , known     :: Bool-    -- | Interpretations of the token, each interpretation annotated-    -- with a /disamb/ Boolean value (if 'True', the interpretation-    -- is correct within the context).-    , interps   :: M.Map Interp Bool }-    deriving (Show, Eq, Ord)-    -data Interp = Interp-    { base  :: Maybe T.Text-    , tag   :: F.Tag }-    deriving (Show, Eq, Ord)--noneBase :: T.Text-noneBase = "None"---- | Create document handler given value of the /ignore/ tag.-plainFormat :: F.Tag -> F.Doc [] [Token] Token-plainFormat ign = F.Doc (parsePlain ign) (showPlain ign) sentHandler---- | Sentence handler.-sentHandler :: F.Sent [Token] Token-sentHandler = F.Sent id (\xs _ -> xs) wordHandler---- | Word handler.-wordHandler :: F.Word Token-wordHandler = F.Word extract select---- | Extract information relevant for tagging.-extract :: Token -> Mx.Word F.Tag-extract tok = Mx.Word-    { Mx.orth       = orth tok-    , Mx.tagWMap    = Mx.mkWMap-        [ (tag x, if disamb then 1 else 0)-        | (x, disamb) <- M.toList (interps tok) ]-    , Mx.oov        = not (known tok) }---- | Select interpretations.-select :: Mx.WMap F.Tag -> Token -> Token-select wMap tok =-    tok { interps = newInterps }-  where-    wSet = M.fromList . map (first tag) . M.toList . interps-    asDmb x = if x > 0-        then True-        else False-    newInterps = M.fromList $-        [ case M.lookup (tag interp) (Mx.unWMap wMap) of-            Just x  -> (interp, asDmb x)-            Nothing -> (interp, False)-        | interp <- M.keys (interps tok) ]-            ++ catMaybes-        [ if tag `M.member` wSet tok-            then Nothing-            else Just (Interp Nothing tag, asDmb x)-        | (tag, x) <- M.toList (Mx.unWMap wMap) ]---- | Parse the text in the plain format given the /oov/ tag.-parsePlain :: F.Tag -> L.Text -> [[Token]]-parsePlain ign = map (parseSent ign) . init . L.splitOn "\n\n"---- | Parse the sentence in the plain format given the /oov/ tag.-parseSent :: F.Tag -> L.Text -> [Token]-parseSent ign-    = map (parseWord ignL)-    . groupBy (\_ x -> cond x)-    . L.lines-  where-    cond = ("\t" `L.isPrefixOf`)-    ignL = L.fromStrict ign--parseWord :: L.Text -> [L.Text] -> Token-parseWord ign xs =-    (Token _orth _space _known _interps)-  where-    (_orth, _space) = parseHeader (head xs)-    ys          = map (parseInterp ign) (tail xs)-    _known      = not (Nothing `elem` ys)-    _interps    = M.fromListWith max (catMaybes ys)--parseInterp :: L.Text -> L.Text -> Maybe (Interp, Bool)-parseInterp ign =-    doIt . tail . L.splitOn "\t"-  where-    doIt [form, tag]-        | tag == ign    = Nothing-        | otherwise     = Just $-            (mkInterp form tag, False)-    doIt [form, tag, "disamb"] = Just $-        (mkInterp form tag, True)-    doIt xs = error $ "parseInterp: " ++ show xs-    mkInterp form tag-        | formS == noneBase = Interp Nothing tagS-        | otherwise         = Interp (Just formS) tagS-      where-        formS   = L.toStrict form-        tagS    = L.toStrict tag--parseHeader :: L.Text -> (T.Text, Space)-parseHeader xs =-    let [_orth, space] = L.splitOn "\t" xs-    in  (L.toStrict _orth, parseSpace space)--parseSpace :: L.Text -> Space-parseSpace "none"    = None-parseSpace "space"   = Space-parseSpace "spaces"  = Space	-- Is it not a Maca bug?-parseSpace "newline" = NewLine-parseSpace "newlines" = NewLine -- TODO: Remove this temporary fix-parseSpace xs        = error ("parseSpace: " ++ L.unpack xs)---------------- Printing---------------- | An infix synonym for 'mappend'.-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-{-# INLINE (<>) #-}---- | Show the plain data.-showPlain :: F.Tag -> [[Token]] -> L.Text-showPlain ign =-    L.toLazyText . mconcat  . map (\xs -> buildSent ign xs <> "\n")---- | Show the sentence.-showSent :: F.Tag -> [Token] -> L.Text-showSent ign xs = L.toLazyText $ buildSent ign xs--buildSent :: F.Tag -> [Token] -> L.Builder-buildSent ign = mconcat . map (buildWord ign)--buildWord :: F.Tag -> Token -> L.Builder-buildWord ign tok-    =  L.fromText (orth tok) <> "\t"-    <> buildSpace (space tok) <> "\n"-    <> buildKnown ign (known tok)-    <> buildInterps (M.toList $ interps tok)--buildInterps :: [(Interp, Bool)] -> L.Builder-buildInterps interps = mconcat-    [ "\t" <> buildBase interp <>-      "\t" <> buildTag  interp <>-      if dmb-        then "\tdisamb\n"-        else "\n"-    | (interp, dmb) <- interps ]-  where-    buildTag    = L.fromText . tag-    buildBase x = case base x of-        Just b  -> L.fromText b-        Nothing -> L.fromText noneBase--buildSpace :: Space -> L.Builder-buildSpace None     = "none"-buildSpace Space    = "space"-buildSpace NewLine  = "newline"--buildKnown :: F.Tag -> Bool -> L.Builder-buildKnown _   True     = ""-buildKnown ign False    =  "\t" <> L.fromText noneBase-                        <> "\t" <> L.fromText ign <> "\n"

@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++module NLP.Concraft.Format.Temp+( encodePar+, decodePar+, writePar+, readPar+) where++import qualified Data.ByteString.Lazy.Char8 as BC+import qualified Data.Text as T+import           Data.Aeson++import           NLP.Concraft.Morphosyntax++encodePar :: ToJSON w => [Sent w T.Text] -> BC.ByteString+encodePar = BC.unlines . map encode++decodePar :: FromJSON w => BC.ByteString -> [Sent w T.Text]+decodePar = +    let getRight (Right x) = x+        getRight (Left e)  = error $ "error in decodePar: " ++ e+    in  map (getRight . eitherDecode') . BC.lines++writePar :: ToJSON w => FilePath -> [Sent w T.Text] -> IO ()+writePar path = BC.writeFile path . encodePar++readPar :: FromJSON w => FilePath -> IO [Sent w T.Text]+readPar = fmap decodePar . BC.readFile

@@ -7,9 +7,8 @@   -- * Guessing , guess-, guessSent-, guessDoc , include+, guessSent  -- * Training , TrainConf (..)@@ -19,12 +18,9 @@ import Prelude hiding (words) import Control.Applicative ((<$>), (<*>)) import Data.Binary (Binary, put, get)-import Data.Foldable (Foldable, foldMap) import Data.Text.Binary () import qualified Data.Set as S import qualified Data.Map as M-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L import qualified Data.Vector as V  import qualified Control.Monad.Ox as Ox@@ -32,8 +28,7 @@ import qualified Numeric.SGD as SGD  import NLP.Concraft.Schema hiding (schematize)-import qualified NLP.Concraft.Morphosyntax as Mx-import qualified NLP.Concraft.Format as F+import qualified NLP.Concraft.Morphosyntax as X  -- | A guessing model. data Guesser t = Guesser@@ -45,7 +40,7 @@     get = Guesser <$> get <*> get  -- | Schematize the input sentence with according to 'schema' rules.-schematize :: Ord t => Schema t a -> Mx.Sent t -> CRF.Sent Ob t+schematize :: (X.Word w, Ord t) => Schema w t a -> X.Sent w t -> CRF.Sent Ob t schematize schema sent =     [ CRF.Word (obs i) (lbs i)     | i <- [0 .. n - 1] ]@@ -54,66 +49,37 @@     n = V.length v     obs = S.fromList . Ox.execOx . schema v     lbs i -        | Mx.oov w  = S.empty-        | otherwise = Mx.interpsSet w+        | X.oov w  = S.empty+        | otherwise = X.interpsSet w         where w = v V.! i --- | Determine the 'k' most probable labels for each word in the sentence.-guess :: Ord t => Int -> Guesser t -> Mx.Sent t -> [[t]]+-- | Determine 'k' most probable labels for each word in the sentence.+guess :: (X.Word w, Ord t)+      => Int -> Guesser t -> X.Sent w t -> [[t]] guess k gsr sent =     let schema = fromConf (schemaConf gsr)     in  CRF.tagK k (crf gsr) (schematize schema sent) --- | Include guessing results into weighted tag maps--- assigned to individual words.-includeWMaps :: Ord t => Mx.Sent t -> [[t]] -> [Mx.WMap t]-includeWMaps words guessed =-    [ if Mx.oov word-        then addInterps (Mx.tagWMap word) xs-        else Mx.tagWMap word-    | (xs, word) <- zip guessed words ]+-- | Insert guessing results into the sentence.+include :: (X.Word w, Ord t) => (X.Sent w t -> [[t]])+        -> X.Sent w t -> X.Sent w t+include f sent =+    [ word { X.tags = tags }+    | (word, tags) <- zip sent sentTags ]   where-    -- Add new interpretations.-    addInterps wm xs = Mx.mkWMap-        $  M.toList (Mx.unWMap wm)+    sentTags =+        [ if X.oov word+            then addInterps (X.tags word) xs+            else X.tags word+        | (xs, word) <- zip (f sent) sent ]+    addInterps wm xs = X.mkWMap+        $  M.toList (X.unWMap wm)         ++ zip xs [0, 0 ..] --- | Include guessing results into the sentence.-include :: Ord t => Mx.Sent t -> [[t]] -> Mx.Sent t-include words guessed =-    [ word { Mx.tagWMap = wMap }-    | (word, wMap) <- zip words wMaps ]-  where-    wMaps = includeWMaps words guessed---- | Tag sentence in external format.  Selected interpretations--- (tags correct within the context) will be preserved.-guessSent :: F.Sent s w -> Int -> Guesser F.Tag -> s -> s-guessSent F.Sent{..} k gsr sent = flip mergeSent sent-    [ select wMap word-    | (wMap, word) <- zip wMaps (parseSent sent) ]-  where-    -- Extract word handler.-    F.Word{..} = wordHandler-    -- Word in internal format.-    words   = map extract (parseSent sent)-    -- Guessed lists of interpretations for individual words.-    guessed = guess k gsr words-    -- Resultant weighted maps. -    wMaps   = includeWMaps words guessed---- | Tag file.-guessDoc-    :: Functor f-    => F.Doc f s w  	-- ^ Document format handler-    -> Int              -- ^ Guesser argument-    -> Guesser F.Tag    -- ^ Guesser itself-    -> L.Text           -- ^ Input-    -> L.Text           -- ^ Output-guessDoc F.Doc{..} k gsr-    = showDoc -    . fmap (guessSent sentHandler k gsr)-    . parseDoc+-- | Combine `guess` with `include`. +guessSent :: (X.Word w, Ord t)+          => Int -> Guesser t -> X.Sent w t -> X.Sent w t+guessSent guessNum guesser = include (guess guessNum guesser)  -- | Training configuration. data TrainConf = TrainConf@@ -122,30 +88,27 @@  -- | Train guesser. train-    :: Foldable f-    => F.Doc f s w      -- ^ Document format handler-    -> TrainConf        -- ^ Training configuration-    -> FilePath         -- ^ Training file-    -> Maybe FilePath   -- ^ Maybe eval file-    -> IO (Guesser F.Tag)-train format TrainConf{..} trainPath evalPath'Maybe = do+    :: (X.Word w, Ord t)+    => TrainConf            -- ^ Training configuration+    -> [X.Sent w t]         -- ^ Training data+    -> Maybe [X.Sent w t]   -- ^ Maybe evaluation data+    -> IO (Guesser t)+train TrainConf{..} trainData evalData'Maybe = do     let schema = fromConf schemaConfT     crf <- CRF.train sgdArgsT-        (schemed format schema trainPath)-        (schemed format schema <$> evalPath'Maybe)+        (retSchemed schema trainData)+        (retSchemed schema <$> evalData'Maybe)         (const CRF.presentFeats)     return $ Guesser schemaConfT crf+  where+    retSchemed schema = return . schemed schema  -- | Schematized data from the plain file.-schemed-    :: Foldable f => F.Doc f s w -> Schema F.Tag a-    -> FilePath -> IO [CRF.SentL Ob F.Tag]-schemed F.Doc{..} schema path =-    foldMap onSent . parseDoc <$> L.readFile path+schemed :: (X.Word w, Ord t) => Schema w t a+        -> [X.Sent w t] -> [CRF.SentL Ob t]+schemed schema =+    map onSent   where-    F.Sent{..} = sentHandler-    F.Word{..} = wordHandler-    onSent sent =-        let xs = map extract (parseSent sent)-            mkProb = CRF.mkProb . M.toList . Mx.unWMap . Mx.tagWMap-        in  [zip (schematize schema xs) (map mkProb xs)]+    onSent xs =+        let mkProb = CRF.mkProb . M.toList . X.unWMap . X.tags+        in  zip (schematize schema xs) (map mkProb xs)

@@ -1,67 +1,146 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-} + -- | Types and functions related to the morphosyntax data layer. + module NLP.Concraft.Morphosyntax ( --- * Morphosyntax data-  Sent-, Word (..)-, mapWord-, mapSent+-- * Segment+  Seg (..)+, mapSeg , interpsSet , interps++-- * Word classes+, Word (..)++-- * Sentence+, Sent+, mapSent+, SentO (..)+, mapSentO+ -- * Weighted collection , WMap (unWMap)-, mkWMap , mapWMap+, mkWMap ) where -import Control.Arrow (first)++import           Control.Applicative ((<$>), (<*>))+import           Control.Arrow (first)+import           Data.Aeson 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  --- | A sentence of 'Word's.-type Sent t = [Word t]+--------------------------+-- Segment+-------------------------- --- | A word parametrized over a tag type.-data Word t = Word {++-- | A segment parametrized over a word type and a tag type.+data Seg w t = Seg {+    -- | A word represented by the segment.  Typically it will be+    -- an instance of the `Word` class.+      word  :: w+    -- | A set of interpretations.  To each interpretation+    -- a weight of appropriateness within the context+    -- is assigned.+    , tags  :: WMap t }+    deriving (Show)+++instance ToJSON w => ToJSON (Seg w T.Text) where+    toJSON Seg{..} = object+        [ "word" .= word+        , "tags" .= unWMap tags ]++instance FromJSON w => FromJSON (Seg w T.Text) where+    parseJSON (Object v) = Seg+        <$> v .: "word"+        <*> (WMap <$> v .: "tags")+    parseJSON _ = error "parseJSON (segment): absurd"+++-- | Map function over segment tags.+mapSeg :: Ord b => (a -> b) -> Seg w a -> Seg w b+mapSeg f w = w { tags = mapWMap f (tags w) }+++-- | Interpretations of the segment.+interpsSet :: Seg w t -> S.Set t+interpsSet = M.keysSet . unWMap . tags+++-- | Interpretations of the segment.+interps :: Seg w t -> [t]+interps = S.toList . interpsSet+++--------------------------+-- Word classes+--------------------------+++class Word a where     -- | Orthographic form.-      orth      :: T.Text-    -- | Set of word interpretations.  To each interpretation-    -- a weight of correctness within the context is assigned.-    , tagWMap   :: WMap t-    -- | Out-of-vocabulary (OOV) word, i.e. word unknown to the-    -- morphosyntactic analyser.-    , oov       :: Bool }-    deriving (Show, Eq, Ord)+    orth    :: a -> T.Text +    -- | Out-of-vocabulary (OOV) word.+    oov     :: a -> Bool --- | Map function over word tags.-mapWord :: Ord b => (a -> b) -> Word a -> Word b-mapWord f w = w { tagWMap = mapWMap f (tagWMap w) } +instance Word w => Word (Seg w t) where+    orth = orth . word+    {-# INLINE orth #-}+    oov = oov . word+    {-# INLINE oov #-}+++----------------------+-- Sentence+----------------------+++-- | A sentence.+type Sent w t = [Seg w t]+ -- | Map function over sentence tags.-mapSent :: Ord b => (a -> b) -> Sent a -> Sent b-mapSent = map . mapWord+mapSent :: Ord b => (a -> b) -> Sent w a -> Sent w b+mapSent = map . mapSeg --- | Interpretations of the word.-interpsSet :: Word t -> S.Set t-interpsSet = M.keysSet . unWMap . tagWMap+-- | A sentence with original, textual representation.+data SentO w t = SentO+    { segs  :: Sent w t+    , orig  :: L.Text }+    deriving (Show) --- | Interpretations of the word.-interps :: Word t -> [t]-interps = S.toList . interpsSet+-- | Map function over sentence tags.+mapSentO :: Ord b => (a -> b) -> SentO w a -> SentO w b+mapSentO f x =+    let segs' = mapSent f (segs x)+    in  x { segs = segs' } +----------------------+-- Weighted collection+---------------------- --- | A weighted collection of type @a@ elements.+-- | A set with a non-negative weight assigned to each of+-- its elements. newtype WMap a = WMap { unWMap :: M.Map a Double }     deriving (Show, Eq, Ord) --- | Make a weighted collection.++-- | Make a weighted collection.  Negative elements will be ignored. mkWMap :: Ord a => [(a, Double)] -> WMap a mkWMap = WMap . M.fromListWith (+) . filter ((>=0).snd)+  -- | Map function over weighted collection elements.  mapWMap :: Ord b => (a -> b) -> WMap a -> WMap b

@@ -0,0 +1,79 @@+{-# LANGUAGE TupleSections #-}++-- | Alignment and synchronization.  Currently works only with positional tagsets.++module NLP.Concraft.Morphosyntax.Align+( align+, sync+) where++import           Control.Applicative ((<|>))+import           Data.Maybe (fromJust)+import           Data.List (find)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Char as C+import qualified Data.Text as T+import qualified Data.Tagset.Positional as P++import           NLP.Concraft.Morphosyntax++-- | Synchronize two datasets, taking disamb tags from the first one+-- and the rest of information form the second one.+-- In case of differences in token-level segmentation, reference segmentation+-- (token-level) is assumed.  Otherwise, it would be difficult to choose+-- correct disamb tags.+sync :: Word w => P.Tagset -> [Seg w P.Tag] -> [Seg w P.Tag] -> [Seg w P.Tag]+sync tagset xs ys = concatMap (uncurry (moveDisamb tagset)) (align xs ys)++-- | If both arguments contain only one segment, insert disamb interpretations+-- from the first segment into the second segment.  Otherwise, the first list+-- of segments will be returned unchanged.+moveDisamb :: P.Tagset -> [Seg w P.Tag] -> [Seg w P.Tag] -> [Seg w P.Tag]+moveDisamb tagset [v] [w] =+    [w {tags = mkWMap (map (,0) tagsNew ++ disambNew)}]+  where+    -- Return list of (tag, weight) pairs assigned to the segment.+    tagPairs    = M.toList . unWMap . tags+    -- New tags domain.+    tagsNew     = map fst (tagPairs w)+    -- Disamb list with tags mapped to the new domain.+    disambNew   = [(newDom x, c) | (x, c) <- tagPairs v, c > 0]+    -- Find corresonding tag in the new tags domain.+    newDom tag  = fromJust $+            find ( ==tag) tagsNew   -- Exact match+        <|> find (~==tag) tagsNew   -- Expanded tag match+        <|> Just tag                -- Controversial+      where+        x ~== y = S.size (label x `S.intersection` label y) > 0+        label   = S.fromList . P.expand tagset+-- Do nothing in this case.+moveDisamb _ xs _ = xs++-- | Align two lists of segments.+align :: Word w => [Seg w t] -> [Seg w t] -> [([Seg w t], [Seg w t])]+align [] [] = []+align [] _  = error "align: null xs, not null ys"+align _  [] = error "align: not null xs, null ys"+align xs ys =+    let (x, y) = match xs ys+        rest   = align (drop (length x) xs) (drop (length y) ys)+    in  (x, y) : rest++-- | Find the shortest, length-matching prefixes in the two input lists.+match :: Word w => [Seg w t] -> [Seg w t] -> ([Seg w t], [Seg w t])+match xs' ys' =+    doIt 0 xs' 0 ys'+  where+    doIt i (x:xs) j (y:ys)+        | n == m    = ([x], [y])+        | n <  m    = addL x $ doIt n xs j (y:ys)+        | otherwise = addR y $ doIt i (x:xs) m ys+      where+        n = i + size x+        m = j + size y+    doIt _ [] _ _   = error "match: the first argument is null"+    doIt _ _  _ []  = error "match: the second argument is null"+    size w = T.length . T.filter (not.C.isSpace) $ orth w+    addL x (xs, ys) = (x:xs, ys)+    addR y (xs, ys) = (xs, y:ys)

@@ -24,9 +24,6 @@ , nullConf , fromConf -, guessConfDefault-, disambConfDefault- -- * Schema blocks , Block , fromBlock@@ -48,27 +45,27 @@ import qualified Control.Monad.Ox as Ox import qualified Control.Monad.Ox.Text as Ox -import qualified NLP.Concraft.Morphosyntax as Mx+import qualified NLP.Concraft.Morphosyntax as X  -- | An observation consist of an index (of list type) and an actual -- observation value. type Ob = ([Int], T.Text)  -- | The Ox monad specialized to word token type and text observations.-type Ox t a = Ox.Ox (Mx.Word t) T.Text a+type Ox a = Ox.Ox 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 t a = V.Vector (Mx.Word t) -> Int -> Ox t a+type Schema w t a = V.Vector (X.Seg w t) -> Int -> Ox a  -- | A dummy schema block.-void :: a -> Schema t a+void :: a -> Schema w t a void x _ _ = return x  -- | Sequence the list of schemas (or blocks) and discard individual values. sequenceS_-    :: [V.Vector (Mx.Word t) -> a -> Ox t b]-    ->  V.Vector (Mx.Word t) -> a -> Ox t ()+    :: [V.Vector (X.Seg w t) -> a -> Ox b]+    ->  V.Vector (X.Seg w t) -> a -> Ox () sequenceS_ xs sent =     let ys = map ($sent) xs     in  \k -> sequence_ (map ($k) ys)@@ -79,48 +76,48 @@     , lowOrth       :: Int -> Maybe T.Text }  -- | Construct the 'BaseOb' structure given the sentence.-mkBaseOb :: V.Vector (Mx.Word t) -> BaseOb+mkBaseOb :: X.Word w => V.Vector (X.Seg w t) -> BaseOb mkBaseOb sent = BaseOb     { orth      = _orth     , lowOrth   = _lowOrth }   where     at          = Ox.atWith sent-    _orth       = (Mx.orth `at`)+    _orth       = (X.orth `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 t a = V.Vector (Mx.Word t) -> [Int] -> Ox t a+type Block w t a = V.Vector (X.Seg w t) -> [Int] -> Ox a  -- | Transform a block to a schema depending on -- * A list of relative sentence positions, -- * A boolean value; if true, the block computation --   will be performed only on positions where an OOV --   word resides.-fromBlock :: Block t a -> [Int] -> Bool -> Schema t a+fromBlock :: X.Word w => Block w t a -> [Int] -> Bool -> Schema w t a fromBlock blk xs oovOnly sent =     \k -> blkSent [x + k | x <- xs, oov (x + k)]   where     blkSent = blk sent     oov k   = if not oovOnly         then True-        else maybe False id $ Mx.oov `at` k+        else maybe False id $ X.oov `at` k     at      = Ox.atWith sent  -- | Orthographic form at the current position.-orthB :: Block t ()+orthB :: X.Word w => Block w t () orthB sent = \ks ->-    let orthOb = Ox.atWith sent Mx.orth+    let orthOb = Ox.atWith sent X.orth     in  mapM_ (Ox.save . orthOb) ks  -- | Orthographic form at the current position.-lowOrthB :: Block t ()+lowOrthB :: X.Word w => Block w t () lowOrthB sent = \ks ->     let BaseOb{..} = mkBaseOb sent     in  mapM_ (Ox.save . lowOrth) ks  -- | List of lowercased prefixes of given lengths.-lowPrefixesB :: [Int] -> Block t ()+lowPrefixesB :: X.Word w => [Int] -> Block w t () lowPrefixesB ns sent = \ks ->     forM_ ks $ \i ->         mapM_ (Ox.save . lowPrefix i) ns@@ -129,7 +126,7 @@     lowPrefix i j   = Ox.prefix j =<< lowOrth i  -- | List of lowercased suffixes of given lengths.-lowSuffixesB :: [Int] -> Block t ()+lowSuffixesB :: X.Word w => [Int] -> Block w t () lowSuffixesB ns sent = \ks ->     forM_ ks $ \i ->         mapM_ (Ox.save . lowSuffix i) ns@@ -138,17 +135,17 @@     lowSuffix i j   = Ox.suffix j =<< lowOrth i  -- | Shape of the word.-knownB :: Block t ()+knownB :: X.Word w => Block w t () knownB sent = \ks -> do     mapM_ (Ox.save . knownAt) ks   where     at          = Ox.atWith sent-    knownAt i   = boolF <$> (not . Mx.oov) `at` i+    knownAt i   = boolF <$> (not . X.oov) `at` i     boolF True  = "T"     boolF False = "F"  -- | Shape of the word.-shapeB :: Block t ()+shapeB :: X.Word w => Block w t () shapeB sent = \ks -> do     mapM_ (Ox.save . shape) ks   where@@ -156,7 +153,7 @@     shape i         = Ox.shape <$> orth i  -- | Packed shape of the word.-packedB :: Block t ()+packedB :: X.Word w => Block w t () packedB sent = \ks -> do     mapM_ (Ox.save . shapeP) ks   where@@ -165,7 +162,7 @@     shapeP i        = Ox.pack <$> shape i  -- | Packed shape of the word.-begPackedB :: Block t ()+begPackedB :: X.Word w => Block w t () begPackedB sent = \ks -> do     mapM_ (Ox.save . begPacked) ks   where@@ -179,7 +176,7 @@     x <> y          = T.append <$> x <*> y  -- -- | Combined shapes of two consecutive (at @k-1@ and @k@ positions) words.--- shapePairB :: Block t ()+-- shapePairB :: Block w t () -- shapePairB sent = \ks -> --     forM_ ks $ \i -> do --         Ox.save $ link <$> shape  i <*> shape  (i - 1)@@ -190,7 +187,7 @@ --  -- -- | Combined packed shapes of two consecutive (at @k-1@ and @k@ positions) -- -- words.--- packedPairB :: Block t ()+-- packedPairB :: Block w t () -- packedPairB sent = \ks -> --     forM_ ks $ \i -> do --         Ox.save $ link <$> shapeP i <*> shapeP (i - 1)@@ -272,16 +269,16 @@     Nothing Nothing Nothing Nothing     Nothing Nothing Nothing Nothing -mkArg0 :: Block t () -> Entry () -> Schema t ()+mkArg0 :: X.Word w => Block w t () -> Entry () -> Schema w t () mkArg0 blk (Just x) = fromBlock blk (range x) (oovOnly x) mkArg0 _   Nothing  = void () -mkArg1 :: (a -> Block t ()) -> Entry a -> Schema t ()+mkArg1 :: X.Word w => (a -> Block w t ()) -> Entry a -> Schema w t () mkArg1 blk (Just x) = fromBlock (blk (args x)) (range x) (oovOnly x) mkArg1 _   Nothing  = void ()  -- | Build the schema based on the configuration.-fromConf :: SchemaConf -> Schema t ()+fromConf :: X.Word w => SchemaConf -> Schema w t () fromConf SchemaConf{..} = sequenceS_     [ mkArg0 orthB orthC     , mkArg0 lowOrthB lowOrthC@@ -292,80 +289,8 @@     , mkArg0 packedB packedC     , mkArg0 begPackedB begPackedC ] --- -- | Use the schema to extract observations from the sentence.--- schematize :: Schema t a -> [Mx.Word t] -> 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-------------------------------------- Default schema configurations.-------------------------------------- | Default configuration for the guessing observation schema.-guessConfDefault :: SchemaConf-guessConfDefault = nullConf-    { lowPrefixesC  = entryWith [1, 2]      [0]-    , lowSuffixesC  = entryWith [1, 2]      [0]-    , knownC        = entry                 [0]-    , begPackedC    = entry                 [0] }---- -- | Default guessing schema.--- guessSchemaDefault :: Schema t ()--- guessSchemaDefault sent = \k -> do---     mapM_ (Ox.save . lowPref k) [1, 2]---     mapM_ (Ox.save . lowSuff k) [1, 2]---     Ox.save (knownAt k)---     Ox.save (isBeg k <> pure "-" <> shapeP k)---   where---     at          = Ox.atWith sent---     lowOrth i   = T.toLower <$> Mx.orth `at` i---     lowPref i j = Ox.prefix j =<< lowOrth i---     lowSuff i j = Ox.suffix j =<< lowOrth i---     shape i     = Ox.shape <$> Mx.orth `at` i---     shapeP i    = Ox.pack <$> shape i---     knownAt i   = boolF <$> (not . Mx.oov) `at` i---     isBeg i     = (Just . boolF) (i == 0)---     boolF True  = "T"---     boolF False = "F"---     x <> y      = T.append <$> x <*> y---- | Default configuration for the guessing observation schema.-disambConfDefault :: SchemaConf-disambConfDefault = nullConf-    { lowOrthC      = entry                         [-1, 0, 1]-    , lowPrefixesC  = oov $ entryWith [1, 2, 3]     [0]-    , lowSuffixesC  = oov $ entryWith [1, 2, 3]     [0]-    , begPackedC    = oov $ entry                   [0] }-  where-    oov (Just body) = Just $ body { oovOnly = True }-    oov Nothing     = Nothing---- -- | Default disambiguation schema.--- disambSchemaDefault :: Schema t ()--- disambSchemaDefault sent = \k -> do---     mapM_ (Ox.save . lowOrth) [k - 1, k, k + 1]---     _ <- Ox.whenJT (Mx.oov `at` k) $ do---         mapM_ (Ox.save . lowPref k) [1, 2, 3]---         mapM_ (Ox.save . lowSuff k) [1, 2, 3]---         Ox.save (isBeg k <> pure "-" <> shapeP k)---     return ()---   where---     at          = Ox.atWith sent---     lowOrth i   = T.toLower <$> Mx.orth `at` i---     lowPref i j = Ox.prefix j =<< lowOrth i---     lowSuff i j = Ox.suffix j =<< lowOrth i---     shape i     = Ox.shape <$> Mx.orth `at` i---     shapeP i    = Ox.pack <$> shape i---     isBeg i     = (Just . boolF) (i == 0)---     boolF True  = "T"---     boolF False = "F"---     x <> y      = T.append <$> x <*> y- -- | Use the schema to extract observations from the sentence.-schematize :: Schema t a -> Mx.Sent t -> [[Ob]]+schematize :: Schema w t a -> X.Sent w t -> [[Ob]] schematize schema xs =     map (Ox.execOx . schema v) [0 .. n - 1]   where

@@ -1,106 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}--import Control.Applicative ((<$>), (<*>))-import Control.Monad (when)-import System.Console.CmdArgs-import Data.Binary (encodeFile, decodeFile)-import qualified Numeric.SGD as SGD-import qualified Data.Text as T-import qualified Data.Text.Lazy.IO as L-import qualified Data.Tagset.Positional as P--import NLP.Concraft.Format.Plain (plainFormat)-import qualified NLP.Concraft as C-import qualified NLP.Concraft.Schema as S-import qualified NLP.Concraft.Guess as G-import qualified NLP.Concraft.Disamb as D---- | Data formats. -data Format = Plain deriving (Data, Typeable, Show)--data Concraft-  = Train-    { trainPath	    :: FilePath-    , evalPath      :: Maybe FilePath-    , format        :: Format-    -- TODO: ignore tag should be related only to the Plain-    -- format, but then 'Format' would not be an Enum instance.-    -- Try another command line parsing library?-    , tagsetPath    :: FilePath-    , ignTag        :: String-    -- , discardHidden :: Bool-    , iterNum       :: Double-    , batchSize     :: Int-    , regVar        :: Double-    , gain0         :: Double-    , tau           :: Double-    , outModel      :: FilePath-    , guessNum      :: Int }-  | Disamb-    { format        :: Format-    , ignTag        :: String-    , inModel       :: FilePath }-    -- , guessNum      :: Int }-  deriving (Data, Typeable, Show)--trainMode :: Concraft-trainMode = Train-    { tagsetPath = def &= argPos 0 &= typ "TAGSET-PATH"-    , trainPath = def &= argPos 1 &= typ "TRAIN-FILE"-    , evalPath = def &= typFile &= help "Evaluation file"-    , format = enum [Plain &= help "Plain format"]-    , ignTag = "ign" &= help "Tag indicating OOV word"-    -- , discardHidden = False &= help "Discard hidden features"-    , iterNum = 10 &= help "Number of SGD iterations"-    , batchSize = 30 &= help "Batch size"-    , regVar = 10.0 &= help "Regularization variance"-    , gain0 = 1.0 &= help "Initial gain parameter"-    , tau = 5.0 &= help "Initial tau parameter"-    , outModel = def &= typFile &= help "Output Model file"-    , guessNum = 10 &= help "Number of guessed tags for each unknown word" }--disambMode :: Concraft-disambMode = Disamb-    { inModel = def &= argPos 0 &= typ "MODEL-FILE"-    , format = enum [Plain &= help "Plain format"]-    , ignTag = "ign" &= help "Tag indicating OOV word" }-    -- , guessNum = 10 &= help "Number of guessed tags for each unknown word" }--argModes :: Mode (CmdArgs Concraft)-argModes = cmdArgsMode $ modes [trainMode, disambMode]--main :: IO ()-main = exec =<< cmdArgsRun argModes--exec :: Concraft -> IO ()--exec Train{..} = do-    tagset <- P.parseTagset tagsetPath <$> readFile tagsetPath-    concraft <- case format of-        Plain   -> train (plainFormat ign) tagset-    when (not . null $ outModel) $ do-        putStrLn $ "\nSaving model in " ++ outModel ++ "..."-        encodeFile outModel concraft-  where-    train docH tagset =-        let guessConf  = G.TrainConf S.guessConfDefault sgdArgs-            disambConf = D.TrainConf tagset D.tiersDefault-                S.disambConfDefault sgdArgs-        in  C.train docH guessNum guessConf disambConf trainPath evalPath -    ign = T.pack ignTag-    sgdArgs = SGD.SgdArgs-        { SGD.batchSize = batchSize-        , SGD.regVar = regVar-        , SGD.iterNum = iterNum-        , SGD.gain0 = gain0-        , SGD.tau = tau }--exec Disamb{..} = do-    tag <- tagWith <$> decodeFile inModel <*> L.getContents-    case format of-        Plain   -> L.putStr $ tag (plainFormat ign)-  where-    tagWith concraft input docH = C.tagDoc docH concraft input-    ign = T.pack ignTag