concraft 0.3.2 → 0.4.0

raw patch · 20 files changed

+1457/−1205 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• NLP/Concraft.hs +0/−143
• NLP/Concraft/Disamb.hs +0/−147
• NLP/Concraft/Disamb/Positional.hs +0/−64
• NLP/Concraft/Disamb/Tiered.hs +0/−265
• NLP/Concraft/Format.hs +0/−44
• NLP/Concraft/Format/Plain.hs +0/−187
• NLP/Concraft/Guess.hs +0/−134
• NLP/Concraft/Morphosyntax.hs +0/−68
• NLP/Concraft/Schema.hs +0/−69
• concraft.cabal +9/−19
• src/NLP/Concraft.hs +99/−0
• src/NLP/Concraft/Disamb.hs +163/−0
• src/NLP/Concraft/Disamb/Positional.hs +64/−0
• src/NLP/Concraft/Disamb/Tiered.hs +258/−0
• src/NLP/Concraft/Format.hs +44/−0
• src/NLP/Concraft/Format/Plain.hs +208/−0
• src/NLP/Concraft/Guess.hs +151/−0
• src/NLP/Concraft/Morphosyntax.hs +68/−0
• src/NLP/Concraft/Schema.hs +373/−0
• tools/concraft.hs +20/−65

@@ -1,143 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module NLP.Concraft-( GuessConf (..)-, GuessData (..)-, DisambConf (..)-, DisambWith (..)-, DisambTag-, DisambTrain-, disamb-, disambDoc-, trainOn-) where---- import Data.Binary (Binary, put, get)--- import qualified Data.Text as T--import System.IO (hClose)-import Data.Foldable (Foldable)-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L-import qualified Numeric.SGD as SGD-import qualified System.IO.Temp as Temp--import NLP.Concraft.Schema-import qualified NLP.Concraft.Morphosyntax as Mx-import qualified NLP.Concraft.Format as F-import qualified NLP.Concraft.Guess as G-import qualified NLP.Concraft.Disamb as D---- | Guessing configuration.-data GuessConf r = GuessConf-    { guessNum      :: Int-    , guessSchema   :: Schema r () }---- | Guessing configuration and model data.-data GuessData r = GuessData-    { guessConf     :: GuessConf r-    , guesser       :: G.Guesser r }---- | Disambiguation configuration.-data DisambConf r t = DisambConf-    { split         :: D.Split r t-    , disambSchema  :: Schema t () }---- | Disambiguation configuration with...-data DisambWith r t a = DisambWith-    { disambConf    :: DisambConf r t-    , disambWith    :: a }---- | Tagging with disambiguation configuration.-type DisambTag r t = DisambWith r t (D.TagCRF Ob t)---- | Training disambiguation model configuration.-type DisambTrain r t c = DisambWith r t (D.TrainCRF Ob t c)---- | Perform disambiguation preceded by context-sensitive guessing.-disamb-    :: (Ord r, Ord t)-    => GuessData r      -- ^ Guessing configuration-    -> DisambTag r t    -- ^ Disambiguation configuration-    -> Mx.Sent r        -- ^ Input-    -> [r]              -- ^ Output-disamb GuessData{..} DisambWith{..} sent-    = D.disamb disambSchema split tagCRF-    . G.include sent -    . G.guess guessNum guessSchema guesser -    $ sent-  where-    GuessConf{..}   = guessConf-    DisambConf{..}  = disambConf-    tagCRF          = disambWith---- | Tag the sentence.-disambSent-    :: Ord t-    => F.Sent s w-    -> GuessData F.Tag-    -> DisambTag F.Tag t-    -> s -> s-disambSent sentH GuessData{..} DisambWith{..}-    = D.disambSent sentH disambSchema split tagCRF-    . G.guessSent  sentH guessNum guessSchema guesser-  where-    GuessConf{..}   = guessConf-    DisambConf{..}  = disambConf-    tagCRF          = disambWith---- | Tag document.-disambDoc-    :: (Functor f, Ord t)-    => F.Doc f s w          -- ^ Document format handler-    -> GuessData F.Tag      -- ^ Guessing configuration-    -> DisambTag F.Tag t    -- ^ Disambiguation configuration-    -> L.Text               -- ^ Input-    -> L.Text               -- ^ Output-disambDoc F.Doc{..} guessData disambTag  =-    let onSent = disambSent sentHandler guessData disambTag-    in  showDoc . fmap onSent . parseDoc---- | Train guessing and disambiguation models.-trainOn-    :: (Functor f, Foldable f, Ord t)-    => F.Doc f s w              -- ^ Document format handler-    -> GuessConf F.Tag          -- ^ Guessing configuration-    -> SGD.SgdArgs              -- ^ SGD params for guesser-    -> DisambTrain F.Tag t c    -- ^ Disambiguation configuration-    -> FilePath                 -- ^ Training file-    -> Maybe FilePath           -- ^ Maybe eval file-    -> IO (G.Guesser F.Tag, c)  -- ^ Resultant models-trainOn format guessConf@GuessConf{..} sgdArgs DisambWith{..}-        trainPath evalPath'Maybe = do-    putStrLn "\n===== Train guessing model ====\n"-    guesser <- G.trainOn format guessSchema sgdArgs-                    trainPath evalPath'Maybe-    let guessData = GuessData guessConf guesser-    let withGuesser = guessFile format guessData-    withGuesser "train" (Just trainPath) $ \(Just trainPathG) ->-      withGuesser "eval"   evalPath'Maybe  $ \evalPathG'Maybe  -> do-        putStrLn "\n===== Train disambiguation model ====\n"-        let DisambConf{..} = disambConf-        let trainCRF = disambWith-        disambCRF <- D.trainOn format disambSchema split trainCRF-                        trainPathG evalPathG'Maybe-        return (guesser, disambCRF)--guessFile-    :: Functor f-    => F.Doc f s w              -- ^ Document format handler-    -> GuessData F.Tag          -- ^ Guesser-    -> String                   -- ^ Template for temporary file name-    -> Maybe FilePath           -- ^ File to guess-    -> (Maybe FilePath -> IO a) -- ^ Handler-    -> IO a-guessFile _ _ _ Nothing handler = handler Nothing-guessFile format GuessData{..} tmpl (Just path) handler =-    Temp.withTempFile "." tmpl $ \tmpPath tmpHandle -> do-        inp <- L.readFile path-        let GuessConf{..} = guessConf-        let out = G.guessDoc format guessNum guessSchema guesser inp-	hClose tmpHandle-        L.writeFile tmpPath out-        handler (Just tmpPath)

@@ -1,147 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module NLP.Concraft.Disamb-( Split-, TrainCRF-, TagCRF-, disamb-, disambSent-, disambDoc-, trainOn-) where--import Control.Applicative ((<$>))-import Data.Maybe (fromJust)-import Data.List (find)-import Data.Foldable (Foldable, foldMap)-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-import qualified NLP.Concraft.Morphosyntax as Mx-import qualified NLP.Concraft.Format as F---- | Schematize the input sentence with according to 'schema' rules.-schematize :: Schema t a -> Mx.Sent t -> CRF.Sent Ob t-schematize schema sent =-    [ CRF.mkWord (obs i) (lbs i)-    | i <- [0 .. n - 1] ]-  where-    v = V.fromList sent-    n = V.length v-    obs = S.fromList . Ox.execOx . schema v-    lbs i = Mx.interpsSet w-        where w = v V.! i---- | Split is just a function from an original tag form--- to a complex tag form.-type Split r t = r -> t---- | Unsplit the complex tag (assuming, that it is one--- of the interpretations of the word).-unSplit :: Eq t => Split 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]---- | Perform context-sensitive disambiguation.-disamb-    :: (Ord r, Ord t)-    => Schema t a-    -> Split r t-    -> TagCRF Ob t-    -> Mx.Sent r-    -> [r]-disamb schema split tag sent-    = map (uncurry embed)-    . zip sent-    . tag-    . schematize schema-    . Mx.mapSent split-    $ sent-  where-    embed = unSplit split---- | Tag the sentence.-disambSent-    :: Ord t-    => F.Sent s w-    -> Schema t a-    -> Split F.Tag t-    -> TagCRF Ob t-    -> s -> s-disambSent F.Sent{..} schema split tag sent =-  flip mergeSent sent-    [ select wMap orig-    | (wMap, orig) <- zip-        (doDmb sent)-        (parseSent sent) ]-  where-    F.Word{..} = wordHandler-    doDmb orig =-        let xs = map extract (parseSent orig)-        in  map (uncurry mkChoice) (zip xs (disamb schema split tag xs))-    mkChoice word x = Mx.mkWMap-        [ if x == y-            then (x, 1)-            else (y, 0)-        | y <- Mx.interps word ]---- | Disambiguate document.-disambDoc-    :: (Functor f, Ord t)-    => F.Doc f s w      -- ^ Document format handler-    -> Schema t a       -- ^ Observation schema-    -> Split F.Tag t    -- ^ Tiered tagging-    -> TagCRF Ob t      -- ^ CRF tagging function-    -> L.Text           -- ^ Input-    -> L.Text           -- ^ Output-disambDoc F.Doc{..} schema split tag =-    let onSent = disambSent sentHandler schema split tag-    in  showDoc . fmap onSent . parseDoc---- | Train disamb model.-trainOn-    :: (Foldable f, Ord t)-    => F.Doc f s w      -- ^ Document format handler-    -> Schema t a       -- ^ Observation schema-    -> Split F.Tag t    -- ^ Tiered tagging-    -> TrainCRF Ob t c  -- ^ CRF training function-    -> FilePath         -- ^ Training file-    -> Maybe FilePath   -- ^ Maybe eval file-    -> IO c             -- ^ Resultant model data-trainOn format schema split train trainPath evalPath'Maybe = do-    crf <- train-        (schemed format schema split trainPath)-        (schemed format schema split <$> evalPath'Maybe)-    return crf---- | Schematized data from the plain file.-schemed-    :: (Foldable f, Ord t)-    => F.Doc f s w -> Schema t a -> Split F.Tag t-    -> FilePath -> IO [CRF.SentL Ob t]-schemed F.Doc{..} schema split path =-    foldMap onSent . parseDoc <$> L.readFile path-  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

@@ -1,64 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}---- | The module provides functions for splitting positional tags.--- They can be used together with the layered disambiguation model.--module NLP.Concraft.Disamb.Positional-( Tier (..)-, Part (..)-, select-, split-, tierConfDefault-) where--import Control.Applicative ((<$>), (<*>))-import Data.Binary (Binary, put, get)-import Data.Text.Binary ()-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Tagset.Positional as TP---- | A tier description.-data Tier = Tier {-    -- | Does it include the part of speech?-      withPos   :: Bool-    -- | Tier grammatical attributes.-    , withAtts  :: S.Set TP.Attr }--instance Binary Tier where-    put Tier{..} = put withPos >> put withAtts-    get = Tier <$> get <*> get---- | An atomic part of morphosyntactic tag with optional POS.-data Part = Part-    { pos   :: Maybe TP.POS-    , atts  :: M.Map TP.Attr T.Text }-    deriving (Show, Eq, Ord)--instance Binary Part where-    put Part{..} = put pos >> put atts-    get = Part <$> get <*> get---- | Select tier attributes.-select :: Tier -> TP.Tag -> Part-select Tier{..} tag = Part-    { pos   = if withPos then Just (TP.pos tag) else Nothing-    , atts  = M.filterWithKey (\k _ -> k `S.member` withAtts) (TP.atts tag) }---- | Split the positional tag.-split :: [Tier] -> TP.Tag -> [Part]-split tiers tag =-    [ select tier tag-    | tier <- tiers ]---- | Default tiered tagging configuration.-tierConfDefault :: [Tier]-tierConfDefault =-    [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,265 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}--module NLP.Concraft.Disamb.Tiered-(--- * Tiered model-  Ob (..)-, Lb (..)-, Feat (..)-, CRF (..)-, train-, tag---- * Feature selection-, FeatSel-, selectHidden-, selectPresent-) where--import Control.Applicative ((<$>), (<*>))-import Control.Comonad.Trans.Store (store)-import Control.Monad (guard)-import Data.Ix (Ix, inRange, range)-import Data.Maybe (catMaybes, fromJust)-import Data.List (zip4, foldl1')-import Data.Lens.Common (Lens(..))-import Data.Binary (Binary, get, put, Put, Get)-import Data.Vector.Binary ()-import qualified Data.Map as M-import qualified Data.Vector as V-import qualified Data.Array.Unboxed as A--import Data.CRF.Chain2.Generic.Codec-    ( Codec(..), mkCodec, encodeDataL-    , encodeSent, decodeLabels, unJust )-import Data.CRF.Chain2.Generic.Model-    ( FeatGen(..), Model, FeatSel-    , selectHidden, selectPresent-    , core, withCore )-import Data.CRF.Chain2.Generic.Internal (FeatIx(..))-import qualified Data.CRF.Chain2.Generic.Inference as I-import qualified Data.CRF.Chain2.Generic.Train as Train-import qualified Data.CRF.Chain2.Generic.FeatMap as F-import qualified Control.Monad.Codec as C-import qualified Numeric.SGD as SGD-import qualified NLP.Concraft.Disamb as D---- | Observation.-newtype Ob = Ob { unOb :: Int } deriving (Show, Eq, Ord, Ix, Binary)---- | [Sub]label.-newtype Lb = Lb { unLb :: Int } deriving (Show, Eq, Ord, Ix, Binary)---- | Feature.-data Feat-    = TFeat3-        { x1    :: {-# UNPACK #-} !Lb-        , x2    :: {-# UNPACK #-} !Lb-        , x3    :: {-# UNPACK #-} !Lb-        , ln    :: {-# UNPACK #-} !Int }-    | TFeat2-        { x1    :: {-# UNPACK #-} !Lb-        , x2    :: {-# UNPACK #-} !Lb-        , ln    :: {-# UNPACK #-} !Int }-    | TFeat1-        { x1    :: {-# UNPACK #-} !Lb-        , ln    :: {-# UNPACK #-} !Int }-    | OFeat-        { ob    :: {-# UNPACK #-} !Ob-        , x1    :: {-# UNPACK #-} !Lb-        , ln    :: {-# UNPACK #-} !Int }-    deriving (Show, Eq, Ord)--instance Binary Feat where-    put (OFeat o x k)       = putI 0 >> put o >> put x >> put k-    put (TFeat3 x y z k)    = putI 1 >> put x >> put y >> put z >> put k-    put (TFeat2 x y k)      = putI 2 >> put x >> put y >> put k-    put (TFeat1 x k)        = putI 3 >> put x >> put k-    get = getI >>= \i -> case i of-        0   -> OFeat  <$> get <*> get <*> get-        1   -> TFeat3 <$> get <*> get <*> get <*> get-        2   -> TFeat2 <$> get <*> get <*> get-        3   -> TFeat1 <$> get <*> get-        _   -> error "get feature: unknown code"--putI :: Int -> Put-putI = put-{-# INLINE putI #-}--getI :: Get Int-getI = get-{-# INLINE getI #-}---- | Feature generation for complex [Lb] label type.-featGen :: FeatGen Ob [Lb] Feat-featGen = FeatGen-    { obFeats   = obFeats'-    , trFeats1  = trFeats1'-    , trFeats2  = trFeats2'-    , trFeats3  = trFeats3' }-  where-    obFeats' ob' xs =-        [ OFeat ob' x k-        | (x, k) <- zip xs [0..] ]-    trFeats1' xs =-        [ TFeat1 x k-        | (x, k) <- zip xs [0..] ]-    trFeats2' xs1 xs2 =-        [ TFeat2 x1' x2' k-        | (x1', x2', k) <--          zip3 xs1 xs2 [0..] ]-    trFeats3' xs1 xs2 xs3 =-        [ TFeat3 x1' x2' x3' k-        | (x1', x2', x3', k) <--          zip4 xs1 xs2 xs3 [0..] ]---- | Codec internal data.  The first component is used to--- encode observations of type a, the second one is used to--- encode labels of type [b].-type CodecData a b =-    ( C.AtomCodec a-    , V.Vector (C.AtomCodec (Maybe b)) )--obLens :: Lens (a, b) a-obLens = Lens $ \(a, b) -> store (\a' -> (a', b)) a--lbLens :: Int -> Lens (a, V.Vector b) b-lbLens k = Lens $ \(a, b) -> store-    (\x -> (a, b V.// [(k, x)]))-    (b V.! k)---- | Codec dependes on the number of layers. -codec :: (Ord a, Ord b) => Int -> Codec a [b] (CodecData a b) Ob [Lb]-codec n = Codec-    { empty =-        let x = C.execCodec C.empty (C.encode C.idLens Nothing)-        in  (C.empty, V.replicate n x)-    , encodeObU = fmap Ob . C.encode' obLens-    , encodeObN = fmap (fmap Ob) . C.maybeEncode obLens-    , encodeLbU = \ xs -> sequence-        [ Lb <$> C.encode (lbLens k) (Just x)-        | (x, k) <- zip xs [0..] ]-    , encodeLbN = \ xs ->-        let encode lens x = C.maybeEncode lens (Just x) >>= \mx -> case mx of-                Just x' -> return x'-                Nothing -> fromJust <$> C.maybeEncode lens Nothing-        in  sequence-                [ Lb <$> encode (lbLens k) x-                | (x, k) <- zip xs [0..] ]-    , decodeLbC = \ xs -> sequence <$> sequence-        [ C.decode (lbLens k) (unLb x)-        | (x, k) <- zip xs [0..] ]-    , hasLabel = \ cdcData xs -> and-        [ M.member-            (Just x)-            (C.to $ snd cdcData V.! k)-        | (x, k) <- zip xs [0..] ] }---- | Dummy feature index.-dummy :: FeatIx-dummy = FeatIx (-1)-{-# INLINE dummy #-}---- | Transition map restricted to a particular tagging layer.-type TransMap = A.UArray (Lb, Lb, Lb) FeatIx---- | CRF feature map.-data FeatMap a = FeatMap-    { transMaps	:: V.Vector TransMap-    , otherMap 	:: M.Map Feat FeatIx }--instance Binary (FeatMap Feat) where-    put FeatMap{..} = put transMaps >> put otherMap-    get = FeatMap <$> get <*> get--instance F.FeatMap FeatMap Feat where-    featIndex (TFeat3 x y z k) (FeatMap v _) = do-        m  <- v V.!? k-        ix <- m !? (x, y, z)-        guard (ix /= dummy)-        return ix-    featIndex x (FeatMap _ m) = M.lookup x m-    mkFeatMap xs = FeatMap-        ( V.fromList-            [ mkArray . catMaybes $-                map (getTFeat3 k) xs-            | k <- [0 .. maxLayerNum xs] ] )-        (M.fromList (filter (isOther . fst) xs))-      where-        maxLayerNum = maximum . map (ln.fst)-        getTFeat3 i (TFeat3 x y z j, v)-            | i == j                = Just ((x, y, z), v)-            | otherwise             = Nothing-        getTFeat3 _ _               = Nothing-        isOther (TFeat3 _ _ _ _)    = False-        isOther _                   = True-        mkArray ys =-            let p = foldl1' updateMin (map fst ys)-                q = foldl1' updateMax (map fst ys)-                updateMin (!x, !y, !z) (x', y', z') =-                    (min x x', min y y', min z z')-                updateMax (!x, !y, !z) (x', y', z') =-                    (max x x', max y y', max z z')-                zeroed pq = A.array pq [(k, dummy) | k <- range pq]-            in  zeroed (p, q) A.// ys--(!?) :: (Ix i, A.IArray a b) => a i b -> i -> Maybe b-m !? x = if inRange (A.bounds m) x-    then Just (m A.! x)-    else Nothing-{-# INLINE (!?) #-}---- | CRF model data.-data CRF a b = CRF-    { numOfLayers   :: Int-    , codecData     :: CodecData a b-    , model         :: Model FeatMap Ob [Lb] Feat }--instance (Ord a, Ord b, Binary a, Binary b) => Binary (CRF a b) where-    put CRF{..} = put numOfLayers >> put codecData >> put (core model)-    get = CRF <$> get <*> get <*> do-        _core <- get-        return $ withCore _core featGen---- | Codec specification given the number of layers.-codecSpec-    :: (Ord a, Ord b) => Int-    -> Train.CodecSpec a [b] (CodecData a b) Ob [Lb]-codecSpec n = Train.CodecSpec-    { Train.mkCodec = mkCodec (codec n)-    , Train.encode  = encodeDataL (codec n) }---- | Train the CRF using the stochastic gradient descent method.--- Use the provided feature selection function to determine model--- features.-train-    :: (Ord o, Ord t)-    => Int                          -- ^ Number of tagging layers-    -> FeatSel Ob [Lb] Feat         -- ^ Feature selection-    -> SGD.SgdArgs                  -- ^ Args for SGD-    -> D.TrainCRF o [t] (CRF o t)-train n featSel sgdArgs trainIO evalIO'Maybe = do-    (_codecData, _model) <- Train.train-        sgdArgs-        (codecSpec n)-        featGen-        featSel-        trainIO-        evalIO'Maybe-    return $ CRF n _codecData _model---- | Find the most probable label sequence.-tag :: (Ord o, Ord t) => CRF o t -> D.TagCRF o [t]-tag CRF{..} sent-    = onWords . decodeLabels cdc codecData-    . I.tag model . encodeSent cdc codecData-    $ sent-  where-    cdc = codec numOfLayers-    onWords xs =-        [ unJust cdc codecData word x-        | (word, x) <- zip sent xs ]

@@ -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---- | Words 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,187 +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-( plainFormat-) 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) ]--parsePlain :: F.Tag -> L.Text -> [[Token]]-parsePlain ign = map (parseSent ign) . init . L.splitOn "\n\n"--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 (<>) #-}--showPlain :: F.Tag -> [[Token]] -> L.Text-showPlain ign =-    L.toLazyText . mconcat  . map (\xs -> buildSent ign xs <> "\n")--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"

@@ -1,134 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module NLP.Concraft.Guess-( Guesser (..)-, guess-, include-, guessSent-, guessDoc-, trainOn-) where--import Prelude hiding (words)-import Control.Applicative ((<$>))-import Data.Binary (Binary)-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-import qualified Data.CRF.Chain1.Constrained as CRF-import qualified Numeric.SGD as SGD--import NLP.Concraft.Schema-import qualified NLP.Concraft.Morphosyntax as Mx-import qualified NLP.Concraft.Format as F---- | Schematize the input sentence with according to 'schema' rules.-schematize :: Ord t => Schema t a -> Mx.Sent t -> CRF.Sent Ob t-schematize schema sent =-    [ CRF.Word (obs i) (lbs i)-    | i <- [0 .. n - 1] ]-  where-    v = V.fromList sent-    n = V.length v-    obs = S.fromList . Ox.execOx . schema v-    lbs i -        | Mx.oov w  = S.empty-        | otherwise = Mx.interpsSet w-        where w = v V.! i---- | A guesser represented by the conditional random field.-newtype Guesser t = Guesser { crf :: CRF.CRF Ob t }-    deriving (Binary)---- | Determine the 'k' most probable labels for each word in the sentence.-guess :: Ord t => Int -> Schema t a -> Guesser t -> Mx.Sent t -> [[t]]-guess k schema gsr sent = 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 ]-  where-    -- Add new interpretations.-    addInterps wm xs = Mx.mkWMap-        $  M.toList (Mx.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 -> Schema F.Tag a -> Guesser F.Tag -> s -> s-guessSent F.Sent{..} k schema 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 schema 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-    -> Schema F.Tag a	-- ^ Observation schema-    -> Guesser F.Tag    -- ^ Guesser itself-    -> L.Text           -- ^ Input-    -> L.Text           -- ^ Output-guessDoc F.Doc{..} k schema gsr-    = showDoc -    . fmap (guessSent sentHandler k schema gsr)-    . parseDoc---- | Train guesser.-trainOn-    :: Foldable f-    => F.Doc f s w      -- ^ Document format handler-    -> Schema F.Tag a	-- ^ Observation schema-    -> SGD.SgdArgs      -- ^ SGD parameters -    -> FilePath         -- ^ Training file-    -> Maybe FilePath   -- ^ Maybe eval file-    -> IO (Guesser F.Tag)-trainOn format schema sgdArgs trainPath evalPath'Maybe = do-    _crf <- CRF.train sgdArgs-        (schemed format schema trainPath)-        (schemed format schema <$> evalPath'Maybe)-        (const CRF.presentFeats)-    return $ Guesser _crf---- | 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-  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)]

@@ -1,68 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---- | Types and functions related to the morphosyntax data layer.--module NLP.Concraft.Morphosyntax-( --- * Morphosyntax data-  Sent-, Word (..)-, mapWord-, mapSent-, interpsSet-, interps--- * Weighted collection-, WMap (unWMap)-, mkWMap-, mapWMap-) where--import Control.Arrow (first)-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.Text as T----- | A sentence of 'Word's.-type Sent t = [Word t]---- | A word parametrized over a tag type.-data Word t = Word {-    -- | 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)---- | Map function over word tags.-mapWord :: Ord b => (a -> b) -> Word a -> Word b-mapWord f w = w { tagWMap = mapWMap f (tagWMap w) }---- | Map function over sentence tags.-mapSent :: Ord b => (a -> b) -> Sent a -> Sent b-mapSent = map . mapWord---- | Interpretations of the word.-interpsSet :: Word t -> S.Set t-interpsSet = M.keysSet . unWMap . tagWMap---- | Interpretations of the word.-interps :: Word t -> [t]-interps = S.toList . interpsSet----- | A weighted collection of type @a@ elements.-newtype WMap a = WMap { unWMap :: M.Map a Double }-    deriving (Show, Eq, Ord)---- | Make a weighted collection.-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-mapWMap f = mkWMap . map (first f) . M.toList . unWMap

@@ -1,69 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module NLP.Concraft.Schema-( Schema-, Ox-, Ob-, guessSchemaDefault-, disambSchemaDefault-) where--import Control.Applicative ((<$>), (<*>), pure)-import qualified Data.Vector as V-import qualified Data.Text as T-import qualified Control.Monad.Ox as Ox-import qualified Control.Monad.Ox.Text as Ox--import qualified NLP.Concraft.Morphosyntax as Mx---- | The Ox monad specialized to word token type and text observations.-type Ox t a = Ox.Ox (Mx.Word t) 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---- | An observation consist of an index (of list type) and an actual--- observation value.-type Ob = ([Int], T.Text)---- | 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 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

@@ -1,5 +1,5 @@ name:               concraft-version:            0.3.2+version:            0.4.0 synopsis:           Morphosyntactic tagging tool based on constrained CRFs description:     A morphosyntactic tagging tool based on constrained conditional@@ -16,6 +16,8 @@ build-type:         Simple  library+    hs-source-dirs: src+     build-depends:         base >= 4 && < 5       , array@@ -37,13 +39,15 @@      exposed-modules:         NLP.Concraft+      , NLP.Concraft.Guess+      , NLP.Concraft.Disamb       , NLP.Concraft.Morphosyntax       , NLP.Concraft.Format       , NLP.Concraft.Format.Plain       , NLP.Concraft.Schema-      , NLP.Concraft.Guess-      , NLP.Concraft.Disamb-      , NLP.Concraft.Disamb.Tiered++    other-modules:+        NLP.Concraft.Disamb.Tiered       , NLP.Concraft.Disamb.Positional      ghc-options: -Wall -O2@@ -52,23 +56,9 @@     type: git     location: https://github.com/kawu/concraft.git --- executable concraft-guess---     build-depends:---         cmdargs---     hs-source-dirs: ., tools---     main-is: concraft-guess.hs    ---     ghc-options: -Wall -O2 -threaded -rtsopts--- --- executable concraft-disamb---     build-depends:---         cmdargs---     hs-source-dirs: ., tools---     main-is: concraft-disamb.hs    ---     ghc-options: -Wall -O2 -threaded -rtsopts- executable concraft     build-depends:         cmdargs-    hs-source-dirs: ., tools+    hs-source-dirs: src, tools     main-is: concraft.hs         ghc-options: -Wall -O2 -threaded -rtsopts

@@ -0,0 +1,99 @@+{-# LANGUAGE RecordWildCards #-}++module NLP.Concraft+(+-- * Types+  Concraft (..)++-- * 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 qualified System.IO.Temp as Temp++import qualified NLP.Concraft.Morphosyntax as Mx+import qualified NLP.Concraft.Format as F+import qualified NLP.Concraft.Guess as G+import qualified NLP.Concraft.Disamb as D++-- | Concraft data.+data Concraft = Concraft+    { guessNum      :: Int+    , guesser       :: G.Guesser F.Tag+    , disamb        :: D.Disamb }++instance Binary Concraft where+    put Concraft{..} = do+        put guessNum+        put guesser+        put disamb+    get = Concraft <$> 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++-- | 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++-- | Train guessing and disambiguation models.+train+    :: (Functor f, Foldable f)+    => F.Doc f s w      -- ^ Document format handler+    -> 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++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+    -> 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)

@@ -0,0 +1,163 @@+{-# LANGUAGE RecordWildCards #-}++module NLP.Concraft.Disamb+(+-- * Model+  Disamb (..)+, Tier.CRF () ++-- * Tiers+, P.Tier (..)+, P.Atom (..)+, P.tiersDefault++-- * Disambiguation+, disamb+, disambSent+, disambDoc++-- * Training+, TrainConf (..)+, train+) where++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.Disamb.Tiered as Tier+import qualified NLP.Concraft.Disamb.Positional as P+import qualified Data.Tagset.Positional as TP+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 sent =+    [ CRF.mkWord (obs i) (lbs i)+    | i <- [0 .. n - 1] ]+  where+    v = V.fromList sent+    n = V.length v+    obs = S.fromList . Ox.execOx . schema v+    lbs i = Mx.interpsSet w+        where w = v V.! i++-- | A disambiguation model.+data Disamb = Disamb+    { tagset        :: TP.Tagset+    , 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++-- | 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]++-- | Perform context-sensitive disambiguation.+disamb :: Disamb -> Mx.Sent F.Tag -> [F.Tag]+disamb Disamb{..} sent+    = map (uncurry embed)+    . zip sent+    . Tier.tag crf+    . schematize schema+    . Mx.mapSent split+    $ sent+  where+    schema  = fromConf schemaConf+    split   = P.split tiers . TP.parseTag tagset+    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) ]+  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 ]++-- | 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++-- | Training configuration.+data TrainConf = TrainConf+    { tagsetT       :: TP.Tagset+    , 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+    crf <- Tier.train+        (length tiersT)+        sgdArgsT+        (schemed format schema split trainPath)+        (schemed format schema split <$> evalPath'Maybe)+    return $ Disamb tagsetT tiersT schemaConfT crf+  where+    schema = fromConf schemaConfT+    split  = P.split tiersT . TP.parseTag tagsetT++-- | 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+  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

@@ -0,0 +1,64 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | The module provides functions for splitting positional tags.+-- They can be used together with the layered disambiguation model.++module NLP.Concraft.Disamb.Positional+( Tier (..)+, Atom (..)+, select+, split+, tiersDefault+) where++import Control.Applicative ((<$>), (<*>))+import Data.Binary (Binary, put, get)+import Data.Text.Binary ()+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Tagset.Positional as TP++-- | A tier description.+data Tier = Tier {+    -- | Does it include the part of speech?+      withPos   :: Bool+    -- | Tier grammatical attributes.+    , withAtts  :: S.Set TP.Attr }++instance Binary Tier where+    put Tier{..} = put withPos >> put withAtts+    get = Tier <$> get <*> get++-- | An atomic part of morphosyntactic tag with optional POS.+data Atom = Atom+    { pos   :: Maybe TP.POS+    , atts  :: M.Map TP.Attr T.Text }+    deriving (Show, Eq, Ord)++instance Binary Atom where+    put Atom{..} = put pos >> put atts+    get = Atom <$> get <*> get++-- | Select tier attributes.+select :: Tier -> TP.Tag -> Atom+select Tier{..} tag = Atom+    { pos   = if withPos then Just (TP.pos tag) else Nothing+    , atts  = M.filterWithKey (\k _ -> k `S.member` withAtts) (TP.atts tag) }++-- | Split the positional tag.+split :: [Tier] -> TP.Tag -> [Atom]+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" ]

@@ -0,0 +1,258 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}++module NLP.Concraft.Disamb.Tiered+( Ob (..)+, Lb (..)+, Feat (..)+, CRF (..)+, train+, tag+) where++import Control.Applicative ((<$>), (<*>))+import Control.Comonad.Trans.Store (store)+import Control.Monad (guard)+import Data.Ix (Ix, inRange, range)+import Data.Maybe (catMaybes, fromJust)+import Data.List (zip4, foldl1')+import Data.Lens.Common (Lens(..))+import Data.Binary (Binary, get, put, Put, Get)+import Data.Vector.Binary ()+import qualified Data.Map as M+import qualified Data.Vector as V+import qualified Data.Array.Unboxed as A++import Data.CRF.Chain2.Generic.Codec+    ( Codec(..), mkCodec, encodeDataL+    , encodeSent, decodeLabels, unJust )+import Data.CRF.Chain2.Generic.Model+    ( FeatGen(..), Model, selectHidden+    , core, withCore )+import Data.CRF.Chain2.Generic.Internal (FeatIx(..))+import qualified Data.CRF.Chain2.Generic.Inference as I+import qualified Data.CRF.Chain2.Generic.External as E+import qualified Data.CRF.Chain2.Generic.Train as Train+import qualified Data.CRF.Chain2.Generic.FeatMap as F+import qualified Control.Monad.Codec as C+import qualified Numeric.SGD as SGD++-- | Observation.+newtype Ob = Ob { unOb :: Int } deriving (Show, Eq, Ord, Ix, Binary)++-- | Sublabel.+newtype Lb = Lb { unLb :: Int } deriving (Show, Eq, Ord, Ix, Binary)++-- | Feature.+data Feat+    = TFeat3+        { x1    :: {-# UNPACK #-} !Lb+        , x2    :: {-# UNPACK #-} !Lb+        , x3    :: {-# UNPACK #-} !Lb+        , ln    :: {-# UNPACK #-} !Int }+    | TFeat2+        { x1    :: {-# UNPACK #-} !Lb+        , x2    :: {-# UNPACK #-} !Lb+        , ln    :: {-# UNPACK #-} !Int }+    | TFeat1+        { x1    :: {-# UNPACK #-} !Lb+        , ln    :: {-# UNPACK #-} !Int }+    | OFeat+        { ob    :: {-# UNPACK #-} !Ob+        , x1    :: {-# UNPACK #-} !Lb+        , ln    :: {-# UNPACK #-} !Int }+    deriving (Show, Eq, Ord)++instance Binary Feat where+    put (OFeat o x k)       = putI 0 >> put o >> put x >> put k+    put (TFeat3 x y z k)    = putI 1 >> put x >> put y >> put z >> put k+    put (TFeat2 x y k)      = putI 2 >> put x >> put y >> put k+    put (TFeat1 x k)        = putI 3 >> put x >> put k+    get = getI >>= \i -> case i of+        0   -> OFeat  <$> get <*> get <*> get+        1   -> TFeat3 <$> get <*> get <*> get <*> get+        2   -> TFeat2 <$> get <*> get <*> get+        3   -> TFeat1 <$> get <*> get+        _   -> error "get feature: unknown code"++putI :: Int -> Put+putI = put+{-# INLINE putI #-}++getI :: Get Int+getI = get+{-# INLINE getI #-}++-- | Feature generation for complex [Lb] label type.+featGen :: FeatGen Ob [Lb] Feat+featGen = FeatGen+    { obFeats   = obFeats'+    , trFeats1  = trFeats1'+    , trFeats2  = trFeats2'+    , trFeats3  = trFeats3' }+  where+    obFeats' ob' xs =+        [ OFeat ob' x k+        | (x, k) <- zip xs [0..] ]+    trFeats1' xs =+        [ TFeat1 x k+        | (x, k) <- zip xs [0..] ]+    trFeats2' xs1 xs2 =+        [ TFeat2 x1' x2' k+        | (x1', x2', k) <-+          zip3 xs1 xs2 [0..] ]+    trFeats3' xs1 xs2 xs3 =+        [ TFeat3 x1' x2' x3' k+        | (x1', x2', x3', k) <-+          zip4 xs1 xs2 xs3 [0..] ]++-- | Codec internal data.  The first component is used to+-- encode observations of type a, the second one is used to+-- encode labels of type [b].+type CodecData a b =+    ( C.AtomCodec a+    , V.Vector (C.AtomCodec (Maybe b)) )++obLens :: Lens (a, b) a+obLens = Lens $ \(a, b) -> store (\a' -> (a', b)) a++lbLens :: Int -> Lens (a, V.Vector b) b+lbLens k = Lens $ \(a, b) -> store+    (\x -> (a, b V.// [(k, x)]))+    (b V.! k)++-- | Codec dependes on the number of layers. +codec :: (Ord a, Ord b) => Int -> Codec a [b] (CodecData a b) Ob [Lb]+codec n = Codec+    { empty =+        let x = C.execCodec C.empty (C.encode C.idLens Nothing)+        in  (C.empty, V.replicate n x)+    , encodeObU = fmap Ob . C.encode' obLens+    , encodeObN = fmap (fmap Ob) . C.maybeEncode obLens+    , encodeLbU = \ xs -> sequence+        [ Lb <$> C.encode (lbLens k) (Just x)+        | (x, k) <- zip xs [0..] ]+    , encodeLbN = \ xs ->+        let encode lens x = C.maybeEncode lens (Just x) >>= \mx -> case mx of+                Just x' -> return x'+                Nothing -> fromJust <$> C.maybeEncode lens Nothing+        in  sequence+                [ Lb <$> encode (lbLens k) x+                | (x, k) <- zip xs [0..] ]+    , decodeLbC = \ xs -> sequence <$> sequence+        [ C.decode (lbLens k) (unLb x)+        | (x, k) <- zip xs [0..] ]+    , hasLabel = \ cdcData xs -> and+        [ M.member+            (Just x)+            (C.to $ snd cdcData V.! k)+        | (x, k) <- zip xs [0..] ] }++-- | Dummy feature index.+dummy :: FeatIx+dummy = FeatIx (-1)+{-# INLINE dummy #-}++-- | Transition map restricted to a particular tagging layer.+type TransMap = A.UArray (Lb, Lb, Lb) FeatIx++-- | CRF feature map.+data FeatMap a = FeatMap+    { transMaps	:: V.Vector TransMap+    , otherMap 	:: M.Map Feat FeatIx }++instance Binary (FeatMap Feat) where+    put FeatMap{..} = put transMaps >> put otherMap+    get = FeatMap <$> get <*> get++instance F.FeatMap FeatMap Feat where+    featIndex (TFeat3 x y z k) (FeatMap v _) = do+        m  <- v V.!? k+        ix <- m !? (x, y, z)+        guard (ix /= dummy)+        return ix+    featIndex x (FeatMap _ m) = M.lookup x m+    mkFeatMap xs = FeatMap+        ( V.fromList+            [ mkArray . catMaybes $+                map (getTFeat3 k) xs+            | k <- [0 .. maxLayerNum xs] ] )+        (M.fromList (filter (isOther . fst) xs))+      where+        maxLayerNum = maximum . map (ln.fst)+        getTFeat3 i (TFeat3 x y z j, v)+            | i == j                = Just ((x, y, z), v)+            | otherwise             = Nothing+        getTFeat3 _ _               = Nothing+        isOther (TFeat3 _ _ _ _)    = False+        isOther _                   = True+        mkArray ys =+            let p = foldl1' updateMin (map fst ys)+                q = foldl1' updateMax (map fst ys)+                updateMin (!x, !y, !z) (x', y', z') =+                    (min x x', min y y', min z z')+                updateMax (!x, !y, !z) (x', y', z') =+                    (max x x', max y y', max z z')+                zeroed pq = A.array pq [(k, dummy) | k <- range pq]+            in  zeroed (p, q) A.// ys++(!?) :: (Ix i, A.IArray a b) => a i b -> i -> Maybe b+m !? x = if inRange (A.bounds m) x+    then Just (m A.! x)+    else Nothing+{-# INLINE (!?) #-}++-- | CRF model data.+data CRF a b = CRF+    { numOfLayers   :: Int+    , codecData     :: CodecData a b+    , model         :: Model FeatMap Ob [Lb] Feat }++instance (Ord a, Ord b, Binary a, Binary b) => Binary (CRF a b) where+    put CRF{..} = put numOfLayers >> put codecData >> put (core model)+    get = CRF <$> get <*> get <*> do+        _core <- get+        return $ withCore _core featGen++-- | Codec specification given the number of layers.+codecSpec+    :: (Ord a, Ord b) => Int+    -> Train.CodecSpec a [b] (CodecData a b) Ob [Lb]+codecSpec n = Train.CodecSpec+    { Train.mkCodec = mkCodec (codec n)+    , Train.encode  = encodeDataL (codec n) }++-- | Train the CRF using the stochastic gradient descent method.+-- Use the provided feature selection function to determine model+-- features.+train+    :: (Ord o, Ord t)+    => Int                          -- ^ Number of tagging layers+    -> SGD.SgdArgs                  -- ^ Args for SGD+    -> IO [E.SentL o [t]]           -- ^ Training data 'IO' action+    -> Maybe (IO [E.SentL o [t]])   -- ^ Maybe evalation data+    -> IO (CRF o t)                 -- ^ Resulting model+train n sgdArgs trainIO evalIO'Maybe = do+    (_codecData, _model) <- Train.train+        sgdArgs+        (codecSpec n)+        featGen+        selectHidden+        trainIO+        evalIO'Maybe+    return $ CRF n _codecData _model++-- | Find the most probable label sequence.+tag :: (Ord o, Ord t) => CRF o t -> E.Sent o [t] -> [[t]]+tag CRF{..} sent+    = onWords . decodeLabels cdc codecData+    . I.tag model . encodeSent cdc codecData+    $ sent+  where+    cdc = codec numOfLayers+    onWords xs =+        [ unJust cdc codecData word x+        | (word, x) <- zip sent xs ]

@@ -0,0 +1,44 @@+-- | 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 }

@@ -0,0 +1,208 @@+{-# 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,151 @@+{-# LANGUAGE RecordWildCards #-}++module NLP.Concraft.Guess+(+-- * Types+  Guesser (..)+ +-- * Guessing+, guess+, guessSent+, guessDoc+, include++-- * Training+, TrainConf (..)+, train+) where++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+import qualified Data.CRF.Chain1.Constrained as CRF+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++-- | A guessing model.+data Guesser t = Guesser+    { schemaConf    :: SchemaConf+    , crf           :: CRF.CRF Ob t }++instance (Ord t, Binary t) => Binary (Guesser t) where+    put Guesser{..} = put schemaConf >> put crf+    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 schema sent =+    [ CRF.Word (obs i) (lbs i)+    | i <- [0 .. n - 1] ]+  where+    v = V.fromList sent+    n = V.length v+    obs = S.fromList . Ox.execOx . schema v+    lbs i +        | Mx.oov w  = S.empty+        | otherwise = Mx.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]]+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 ]+  where+    -- Add new interpretations.+    addInterps wm xs = Mx.mkWMap+        $  M.toList (Mx.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++-- | Training configuration.+data TrainConf = TrainConf+    { schemaConfT   :: SchemaConf+    , sgdArgsT      :: SGD.SgdArgs }++-- | 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+    let schema = fromConf schemaConfT+    crf <- CRF.train sgdArgsT+        (schemed format schema trainPath)+        (schemed format schema <$> evalPath'Maybe)+        (const CRF.presentFeats)+    return $ Guesser schemaConfT crf++-- | 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+  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)]

@@ -0,0 +1,68 @@+{-# LANGUAGE RecordWildCards #-}++-- | Types and functions related to the morphosyntax data layer.++module NLP.Concraft.Morphosyntax+( +-- * Morphosyntax data+  Sent+, Word (..)+, mapWord+, mapSent+, interpsSet+, interps+-- * Weighted collection+, WMap (unWMap)+, mkWMap+, mapWMap+) where++import Control.Arrow (first)+import qualified Data.Set as S+import qualified Data.Map as M+import qualified Data.Text as T+++-- | A sentence of 'Word's.+type Sent t = [Word t]++-- | A word parametrized over a tag type.+data Word t = Word {+    -- | 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)++-- | Map function over word tags.+mapWord :: Ord b => (a -> b) -> Word a -> Word b+mapWord f w = w { tagWMap = mapWMap f (tagWMap w) }++-- | Map function over sentence tags.+mapSent :: Ord b => (a -> b) -> Sent a -> Sent b+mapSent = map . mapWord++-- | Interpretations of the word.+interpsSet :: Word t -> S.Set t+interpsSet = M.keysSet . unWMap . tagWMap++-- | Interpretations of the word.+interps :: Word t -> [t]+interps = S.toList . interpsSet+++-- | A weighted collection of type @a@ elements.+newtype WMap a = WMap { unWMap :: M.Map a Double }+    deriving (Show, Eq, Ord)++-- | Make a weighted collection.+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+mapWMap f = mkWMap . map (first f) . M.toList . unWMap

@@ -0,0 +1,373 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Observation schema blocks for Concraft.++module NLP.Concraft.Schema+( +-- * Types+  Ob+, Ox+, Schema+, void+, sequenceS_++-- * Usage+, schematize++-- * Configuration+, Body (..)+, Entry+, entry+, entryWith+, SchemaConf (..)+, nullConf+, fromConf++, guessConfDefault+, disambConfDefault++-- * Schema blocks+, Block+, fromBlock+, orthB+, lowOrthB+, lowPrefixesB+, lowSuffixesB+, knownB+, shapeB+, packedB+, begPackedB+) where++import Control.Applicative ((<$>), (<*>), pure)+import Control.Monad (forM_)+import Data.Binary (Binary, put, get)+import qualified Data.Vector as V+import qualified Data.Text as T+import qualified Control.Monad.Ox as Ox+import qualified Control.Monad.Ox.Text as Ox++import qualified NLP.Concraft.Morphosyntax as Mx++-- | 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++-- | 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++-- | A dummy schema block.+void :: a -> Schema 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 ()+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 (Mx.Word t) -> BaseOb+mkBaseOb sent = BaseOb+    { orth      = _orth+    , lowOrth   = _lowOrth }+  where+    at          = Ox.atWith sent+    _orth       = (Mx.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++-- | 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 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+    at      = Ox.atWith sent++-- | Orthographic form at the current position.+orthB :: Block t ()+orthB sent = \ks ->+    let orthOb = Ox.atWith sent Mx.orth+    in  mapM_ (Ox.save . orthOb) ks++-- | Orthographic form at the current position.+lowOrthB :: Block 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 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 t ()+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++-- | Shape of the word.+knownB :: Block t ()+knownB sent = \ks -> do+    mapM_ (Ox.save . knownAt) ks+  where+    at          = Ox.atWith sent+    knownAt i   = boolF <$> (not . Mx.oov) `at` i+    boolF True  = "T"+    boolF False = "F"++-- | Shape of the word.+shapeB :: Block t ()+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 t ()+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++-- | Packed shape of the word.+begPackedB :: Block t ()+begPackedB sent = \ks -> do+    mapM_ (Ox.save . begPacked) ks+  where+    BaseOb{..}      = mkBaseOb sent+    shape i         = Ox.shape <$> orth i+    shapeP i        = Ox.pack <$> shape i+    begPacked i     = isBeg i <> pure "-" <> shapeP i+    isBeg i         = (Just . boolF) (i == 0)+    boolF True      = "T"+    boolF False     = "F"+    x <> y          = T.append <$> x <*> y++-- -- | Combined shapes of two consecutive (at @k-1@ and @k@ positions) words.+-- shapePairB :: Block t ()+-- 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 t ()+-- 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]++-- | Body of configuration entry.+data Body a = Body {+    -- | Range argument for the schema block. +      range     :: [Int]+    -- | When true, the entry is used only for oov words.+    , oovOnly   :: Bool+    -- | Additional arguments for the schema block.+    , args      :: a }+    deriving (Show)++instance Binary a => Binary (Body a) where+    put Body{..} = put range >> put oovOnly >> put args+    get = Body <$> get <*> 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 False v)++-- | 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 'lowOrthB' schema block.+    , lowOrthC          :: 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 'knownB' schema block.+    , knownC            :: Entry ()+    -- | The 'shapeB' schema block.+    , shapeC            :: Entry ()+    -- | The 'packedB' schema block.+    , packedC            :: Entry ()+    -- | The 'begPackedB' schema block.+    , begPackedC         :: Entry ()+    } deriving (Show)++instance Binary SchemaConf where+    put SchemaConf{..} = do+        put orthC+        put lowOrthC+        put lowPrefixesC+        put lowSuffixesC+        put knownC+        put shapeC+        put packedC+        put begPackedC+    get = SchemaConf+        <$> 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++mkArg0 :: Block t () -> Entry () -> Schema t ()+mkArg0 blk (Just x) = fromBlock blk (range x) (oovOnly x)+mkArg0 _   Nothing  = void ()++mkArg1 :: (a -> Block t ()) -> Entry a -> Schema 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 SchemaConf{..} = sequenceS_+    [ mkArg0 orthB orthC+    , mkArg0 lowOrthB lowOrthC+    , mkArg1 lowPrefixesB lowPrefixesC+    , mkArg1 lowSuffixesB lowSuffixesC+    , mkArg0 knownB knownC+    , mkArg0 shapeB shapeC+    , 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 xs =+    map (Ox.execOx . schema v) [0 .. n - 1]+  where+    v = V.fromList xs+    n = V.length v

@@ -5,8 +5,7 @@ import Control.Applicative ((<$>), (<*>)) import Control.Monad (when) import System.Console.CmdArgs-import Data.Binary (Binary, put, get, encodeFile, decodeFile)-import Data.Text.Binary ()+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@@ -15,29 +14,12 @@ import NLP.Concraft.Format.Plain (plainFormat) import qualified NLP.Concraft as C import qualified NLP.Concraft.Schema as S-import qualified NLP.Concraft.Format as F import qualified NLP.Concraft.Guess as G-import qualified NLP.Concraft.Disamb.Positional as D-import qualified NLP.Concraft.Disamb.Tiered as R+import qualified NLP.Concraft.Disamb as D  -- | Data formats.  data Format = Plain deriving (Data, Typeable, Show) --- | Concraft data.-data ConcraftData = ConcraftData-    { guesser       :: G.Guesser F.Tag-    , disambModel   :: R.CRF S.Ob D.Part-    , tagset        :: P.Tagset-    , tierConf      :: [D.Tier] }--instance Binary ConcraftData where-    put ConcraftData{..} = do-        put guesser-        put disambModel-        put tagset-        put tierConf-    get = ConcraftData <$> get <*> get <*> get <*> get- data Concraft   = Train     { trainPath	    :: FilePath@@ -48,7 +30,7 @@     -- Try another command line parsing library?     , tagsetPath    :: FilePath     , ignTag        :: String-    , discardHidden :: Bool+    -- , discardHidden :: Bool     , iterNum       :: Double     , batchSize     :: Int     , regVar        :: Double@@ -59,8 +41,8 @@   | Disamb     { format        :: Format     , ignTag        :: String-    , inModel       :: FilePath-    , guessNum      :: Int }+    , inModel       :: FilePath }+    -- , guessNum      :: Int }   deriving (Data, Typeable, Show)  trainMode :: Concraft@@ -70,7 +52,7 @@     , 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"+    -- , discardHidden = False &= help "Discard hidden features"     , iterNum = 10 &= help "Number of SGD iterations"     , batchSize = 30 &= help "Batch size"     , regVar = 10.0 &= help "Regularization variance"@@ -83,8 +65,8 @@ 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" }+    , 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]@@ -95,34 +77,18 @@ exec :: Concraft -> IO ()  exec Train{..} = do-    tagset' <- P.parseTagset tagsetPath <$> readFile tagsetPath-    (guesser', disambModel') <- case format of-        Plain   -> doTrain (plainFormat ign) tagset'-    let concraftData = ConcraftData-            { guesser       = guesser'-            , disambModel   = disambModel'-            , tagset        = tagset'-            , tierConf      = D.tierConfDefault }+    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 concraftData+        encodeFile outModel concraft   where-    doTrain docHandler tagset' = C.trainOn-        docHandler guessConf sgdArgs-        (disambTrain tagset')-        trainPath evalPath-    guessConf = C.GuessConf-        { C.guessNum = guessNum-        , C.guessSchema = S.guessSchemaDefault }-    disambTrain tagset' = C.DisambWith-        { C.disambConf = disambConf tagset'-        , C.disambWith = R.train (length D.tierConfDefault) featSel sgdArgs }-    disambConf tagset' = C.DisambConf-        { C.split = D.split D.tierConfDefault . P.parseTag tagset'-        , disambSchema = S.disambSchemaDefault }-    featSel = if discardHidden-        then R.selectPresent-        else R.selectHidden+    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@@ -132,20 +98,9 @@         , SGD.tau = tau }  exec Disamb{..} = do-    doTag <- doTagWith <$> decodeFile inModel <*> L.getContents+    tag <- tagWith <$> decodeFile inModel <*> L.getContents     case format of-        Plain   -> L.putStr $ doTag (plainFormat ign)+        Plain   -> L.putStr $ tag (plainFormat ign)   where-    doTagWith ConcraftData{..} input docHandler =-        let guessData = C.GuessData-                { C.guessConf = C.GuessConf-                    { C.guessNum = guessNum-                    , guessSchema = S.guessSchemaDefault }-                , C.guesser = guesser }-            disambTag = C.DisambWith-                { C.disambConf = C.DisambConf-                    { C.split = D.split tierConf . P.parseTag tagset-                    , C.disambSchema = S.disambSchemaDefault }-                , C.disambWith = R.tag disambModel }-        in  C.disambDoc docHandler guessData disambTag input+    tagWith concraft input docH = C.tagDoc docH concraft input     ign = T.pack ignTag