concraft 0.2.0 → 0.3.0

raw patch · 14 files changed

+1209/−675 lines, 14 filesdep +arraydep +comonad-transformersdep +data-lensdep ~crf-chain1-constraineddep ~crf-chain2-genericnew-component:exe:concraftPVP ok

version bump matches the API change (PVP)

Dependencies added: array, comonad-transformers, data-lens, monad-codec, temporary, vector-binary

Dependency ranges changed: crf-chain1-constrained, crf-chain2-generic

API changes (from Hackage documentation)

Files

• NLP/Concraft.hs +143/−0
• NLP/Concraft/Disamb.hs +110/−161
• NLP/Concraft/Disamb/Positional.hs +64/−0
• NLP/Concraft/Disamb/Tiered.hs +265/−0
• NLP/Concraft/Format.hs +44/−0
• NLP/Concraft/Format/Plain.hs +186/−0
• NLP/Concraft/Guess.hs +97/−94
• NLP/Concraft/Morphosyntax.hs +46/−48
• NLP/Concraft/Plain.hs +0/−196
• NLP/Concraft/Schema.hs +69/−0
• concraft.cabal +34/−16
• tools/concraft-disamb.hs +0/−86
• tools/concraft-guess.hs +0/−74
• tools/concraft.hs +151/−0

@@ -0,0 +1,143 @@+{-# 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,198 +1,147 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiParamTypeClasses #-}  module NLP.Concraft.Disamb-( Tier (..)-, Tag (..)-, select-, splitWord-, splitSent-, Ox-, Schema-, Ob-, schema-, schematize-, TierConf-, tear-, deTear-, deTears-, Disamb+( Split+, TrainCRF+, TagCRF , disamb-, tagFile-, learn+, disambSent+, disambDoc+, trainOn ) where -import Control.Applicative ((<$>), (<*>))+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.Text as T-import qualified Data.Text.Lazy as L import qualified Data.Vector as V--import Data.Binary (Binary, get, put)-import Data.Text.Binary ()+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.Pair as CRF-import qualified Numeric.SGD as SGD-import qualified Data.Tagset.Positional as TP--import NLP.Concraft.Morphosyntax-import qualified NLP.Concraft.Plain as P---- | 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---- | A tag with optional POS.-data Tag = Tag-    { pos   :: Maybe TP.POS-    , atts  :: M.Map TP.Attr T.Text }-    deriving (Show, Eq, Ord)--instance Binary Tag where-    put Tag{..} = put pos >> put atts-    get = Tag <$> get <*> get---- | Select tier attributes.-select :: Tier -> TP.Tag -> Tag-select Tier{..} tag = Tag-    { pos   = if withPos then Just (TP.pos tag) else Nothing-    , atts  = M.filterWithKey (\k _ -> k `S.member` withAtts) (TP.atts tag) }---- | The Ox monad specialized to word token type and text observations.--- TODO: Move to monad-ox package from here and from the nerf library.-type Ox t a = Ox.Ox (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 (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)+import qualified Data.CRF.Chain2.Generic.External as CRF -schema :: Schema t ()-schema sent = \k -> do-    mapM_ (Ox.save . lowOrth) [k - 1, k, k + 1]-  where-    at          = Ox.atWith sent-    lowOrth i   = T.toLower <$> orth `at` i+import NLP.Concraft.Schema+import qualified NLP.Concraft.Morphosyntax as Mx+import qualified NLP.Concraft.Format as F --- | Schematize the input sentence according to 'schema' rules.-schematize :: Sent t -> CRF.Sent Ob t-schematize sent =+-- | 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 = tags . (v V.!)--type TierConf = (Tier, Tier)--tear :: TierConf -> TP.Tag -> (Tag, Tag)-tear (t1, t2) = (,) <$> select t1 <*> select t2+    lbs i = Mx.interpsSet w+        where w = v V.! i --- | Split tags between two layers.--- TODO: Add support for multiple layers.-splitWord :: TierConf -> Word TP.Tag -> Word (Tag, Tag)-splitWord cfg = mapWord (tear cfg)+-- | Split is just a function from an original tag form+-- to a complex tag form.+type Split r t = r -> t -splitSent :: TierConf -> Sent TP.Tag -> Sent (Tag, Tag)-splitSent ts = map (splitWord ts)+-- | 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) --- | The disambiguation model.-data Disamb = Disamb-    { crf       :: CRF.CRF Ob Tag Tag-    , tagset    :: TP.Tagset-    , tierConf  :: TierConf }+-- | 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 -instance Binary Disamb where-    put Disamb{..} = put crf >> put tagset >> put tierConf-    get = Disamb <$> get <*> get <*> get+-- | CRF tagging function.+type TagCRF o t = CRF.Sent o t -> [t] --- | Determine the most probable label sequence.-disamb :: Disamb -> Sent TP.Tag -> [TP.Tag]-disamb Disamb{..} sent-    = deTears tierConf sent-    . CRF.tag crf-    . schematize-    . splitSent tierConf+-- | 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--deTears :: TierConf -> Sent TP.Tag -> [(Tag, Tag)] -> [TP.Tag]-deTears cfg sent tiered =-    [ deTear cfg word pair-    | (word, pair) <- zip sent tiered ]---- | Unsplit the list of tag pairs.  TODO: It can be done without the--- help of original word.-deTear :: TierConf -> Word TP.Tag -> (Tag, Tag) -> TP.Tag-deTear cfg word tiered =-    fromJust $ find-        ((==tiered) . tear cfg)-        (S.toList $ tags word)+  where+    embed = unSplit split --- | Tag the file.-tagFile-    :: T.Text           -- ^ Tag indicating unknown words-    -> Disamb-    -> FilePath         -- ^ File to tag (plain format)-    -> IO L.Text-tagFile ign dmb path =-    P.showPlain ign . map onSent <$> P.readPlain ign path+-- | 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-    onSent sent =-        [ choose tok y-        | (tok, y) <- zip sent ys ]-      where-        rs = map (fst . P.fromTok) sent-        xs = map (mapWord parseTag) rs-        ys = map showTag (disamb dmb xs)-        choose tok y = P.choose tok (S.singleton y)-        parseTag = TP.parseTag (tagset dmb)-        showTag  = TP.showTag (tagset dmb)+    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 ] --- | TODO: Abstract over the format type.-learn-    :: SGD.SgdArgs      -- ^ SGD parameters -    -> FilePath         -- ^ File with positional tagset definition-    -> T.Text        	-- ^ The tag indicating unknown words-    -> TierConf         -- ^ Tiered tagging configuration-    -> FilePath         -- ^ Train file (plain format)+-- | 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 Disamb-learn sgdArgs tagsetPath ign tierConf trainPath evalPath'Maybe = do-    _tagset <- TP.parseTagset tagsetPath <$> readFile tagsetPath-    _crf <- CRF.train sgdArgs-        (schemed _tagset ign tierConf trainPath)-        (schemed _tagset ign tierConf <$> evalPath'Maybe)-    return $ Disamb _crf _tagset tierConf+    -> 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-    :: TP.Tagset -> T.Text -> TierConf-    -> FilePath -> IO [CRF.SentL Ob (Tag, Tag)]-schemed tagset _ign cfg =-    fmap (map onSent) . P.readPlain _ign+    :: (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 xs') (map mkDist ys')+        [zip (schematize schema xs) (map mkDist xs)]       where-        (xs, ys) = unzip (map P.fromTok sent)-        xs' = map (mapWord   smash) xs-        ys' = map (mapChoice smash) ys-        smash = tear cfg . parseTag-        parseTag = TP.parseTag tagset-        mkDist = CRF.mkDist . M.toList . M.map unPositive+        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 (..)+, 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" ]

@@ -0,0 +1,265 @@+{-# 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 ]

@@ -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++-- | 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 }

@@ -0,0 +1,186 @@+{-# 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 "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,131 +1,134 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module NLP.Concraft.Guess-( Ox-, Schema-, Ob-, schema-, schematize-, Guesser (..)+( Guesser (..) , guess-, tagFile-, learn+, include+, guessSent+, guessDoc+, trainOn ) where -import Control.Applicative (pure, (<$>), (<*>))+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 as T import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L import qualified Data.Vector as V -import Data.Binary (Binary, get, put)-import Data.Text.Binary ()- import qualified Control.Monad.Ox as Ox-import qualified Control.Monad.Ox.Text as Ox import qualified Data.CRF.Chain1.Constrained as CRF import qualified Numeric.SGD as SGD -import NLP.Concraft.Morphosyntax-import qualified NLP.Concraft.Plain as P---- | The Ox monad specialized to word token type and text observations.--- TODO: Move to monad-ox package from here and from the nerf library.-type Ox t a = Ox.Ox (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 (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)--schema :: Schema t ()-schema 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 <$> orth `at` i-    lowPref i j = Ox.prefix j =<< lowOrth i-    lowSuff i j = Ox.suffix j =<< lowOrth i-    shape i     = Ox.shape <$> orth `at` i-    shapeP i    = Ox.pack <$> shape i-    knownAt i   = boolF <$> known `at` i-    isBeg i     = (Just . boolF) (i == 0)-    boolF True  = "T"-    boolF False = "F"-    x <> y      = T.append <$> x <*> y+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 => Sent t -> CRF.Sent Ob t-schematize sent =+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 = tags . (v 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.-data Guesser t = Guesser-    { crf   :: CRF.CRF Ob t -- ^ The CRF model-    , ign   :: t            -- ^ The tag indicating unkown words-    }+newtype Guesser t = Guesser { crf :: CRF.CRF Ob t }+    deriving (Binary) -instance (Ord t, Binary t) => Binary (Guesser t) where-    put Guesser{..} = put crf >> put ign-    get = Guesser <$> get <*> get+-- | 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) --- | Determine the 'k' most probable labels for each unknown word--- in the sentence.-guess :: Ord t => Int -> Guesser t -> Sent t -> [[t]]-guess k gsr sent = CRF.tagK k (crf gsr) (schematize sent)-{-# INLINE guess #-}+-- | 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 ..] --- | Tag the file.-tagFile-    :: Int              -- ^ Guesser argument-    -> Guesser T.Text   -- ^ Guesser itself-    -> FilePath         -- ^ File to tag (plain format)-    -> IO L.Text-tagFile k gsr path =-    P.showPlain (ign gsr) . map onSent <$> P.readPlain (ign gsr) path+-- | 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-    onSent sent =-        let (xs, _) = unzip (map P.fromTok sent)-            yss = guess k gsr xs-        in  [ if P.known tok-                then tok-                else P.addNones False tok ys-            | (tok, ys) <- zip sent yss ]+    wMaps = includeWMaps words guessed --- | TODO: Abstract over the format type.-learn-    :: SGD.SgdArgs      -- ^ SGD parameters -    -> T.Text        	-- ^ The tag indicating unknown words-    -> FilePath         -- ^ Train file (plain format)+-- | 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 T.Text)-learn sgdArgs _ign trainPath evalPath'Maybe = do+    -> IO (Guesser F.Tag)+trainOn format schema sgdArgs trainPath evalPath'Maybe = do     _crf <- CRF.train sgdArgs-        (schemed _ign trainPath)-        (schemed _ign <$> evalPath'Maybe)+        (schemed format schema trainPath)+        (schemed format schema <$> evalPath'Maybe)         (const CRF.presentFeats)-    return $ Guesser _crf _ign+    return $ Guesser _crf  -- | Schematized data from the plain file.-schemed :: T.Text -> FilePath -> IO [CRF.SentL Ob T.Text]-schemed _ign =-    fmap (map onSent) . P.readPlain _ign+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, ys) = unzip (map P.fromTok sent)-            mkDist = CRF.mkDist . M.toList . M.map unPositive-        in  zip (schematize xs) (map mkDist ys)+        let xs = map extract (parseSent sent)+            mkProb = CRF.mkProb . M.toList . Mx.unWMap . Mx.tagWMap+        in  [zip (schematize schema xs) (map mkProb xs)]

@@ -1,70 +1,68 @@ {-# LANGUAGE RecordWildCards #-} +-- | Types and functions related to the morphosyntax data layer.+ module NLP.Concraft.Morphosyntax-( Word (..)+( +-- * Morphosyntax data+  Sent+, Word (..) , mapWord-, Sent-, Choice-, mapChoice-, Positive (unPositive)-, (<+>)-, mkPositive-, best-, known+, mapSent+, interpsSet+, interps+-- * Weighted collection+, WMap (unWMap)+, mkWMap+, mapWMap ) where  import Control.Arrow (first)-import Data.Ord (comparing)-import Data.List (maximumBy) import qualified Data.Set as S import qualified Data.Map as M import qualified Data.Text as T --- | A word parametrized over the tag type.++-- | 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.-    , tags  :: S.Set t }-    deriving (Show, Read, Eq, Ord)+      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 Word{..} = Word-    { orth = orth-    , tags = S.fromList . map f . S.toList $ tags }+mapWord f w = w { tagWMap = mapWMap f (tagWMap w) } --- | A sentence of 'Word's.-type Sent t = [Word t]+-- | Map function over sentence tags.+mapSent :: Ord b => (a -> b) -> Sent a -> Sent b+mapSent = map . mapWord --- | Interpretations chosen in the given context with--- corresponding positive weights.-type Choice t = M.Map t (Positive Double)+-- | Interpretations of the word.+interpsSet :: Word t -> S.Set t+interpsSet = M.keysSet . unWMap . tagWMap --- | Positive number.-newtype Positive a = Positive { unPositive :: a }-    deriving (Show, Eq, Ord)+-- | Interpretations of the word.+interps :: Word t -> [t]+interps = S.toList . interpsSet -(<+>) :: Num a => Positive a -> Positive a -> Positive a-Positive x <+> Positive y = Positive (x + y)-{-# INLINE (<+>) #-} -mapChoice :: Ord b => (a -> b) -> Choice a -> Choice b-mapChoice f = M.fromListWith (<+>) . map (first f) . M.toList--mkPositive :: (Num a, Ord a) => a -> Positive a-mkPositive x-    | x > 0     = Positive x-    | otherwise = error "mkPositive: not a positive number"-{-# INLINE mkPositive #-}+-- | A weighted collection of type @a@ elements.+newtype WMap a = WMap { unWMap :: M.Map a Double }+    deriving (Show, Eq, Ord) --- | Retrieve the most probable interpretation.-best :: Choice t -> t-best c-    | M.null c  = error "best: null choice" -    | otherwise = fst . maximumBy (comparing snd) $ M.toList c+-- | Make a weighted collection.+mkWMap :: Ord a => [(a, Double)] -> WMap a+mkWMap = WMap . M.fromListWith (+) . filter ((>=0).snd) --- | A word is considered to be known when the set of possible--- interpretations is not empty.-known :: Word t -> Bool-known = not . S.null . tags-{-# INLINE known #-}+-- | 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,196 +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.Plain-(--- * Types-  Space (..)-, Token (..)-, Interp (..)---- * Interface-, fromTok-, choose-, addInterps-, addNones---- * Parsing-, readPlain-, parsePlain-, parseSent---- * Showing-, writePlain-, showPlain-, showSent-, showWord-) where--import Data.Monoid (Monoid, mappend, mconcat)-import Data.Maybe (catMaybes)-import Data.List (groupBy)-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.IO as L-import qualified Data.Text.Lazy.Builder as L--import qualified NLP.Concraft.Morphosyntax as Mx---- | 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 with disambiguation info.-    , interps   :: M.Map Interp Bool }-    deriving (Show, Eq, Ord)-    -data Interp = Interp-    { base      :: T.Text-    , tag       :: T.Text }-    deriving (Show, Eq, Ord)---- | Extract information relevant for tagging.-fromTok :: Token -> (Mx.Word T.Text, Mx.Choice T.Text)-fromTok tok =-    (word, choice)-  where-    word = Mx.Word-        { Mx.orth   = orth tok-        , Mx.tags   = if known tok-            then S.fromList . map tag . M.keys $ interps tok-            else S.empty }-    choice = M.fromListWith (Mx.<+>)-        [ (tag x, Mx.mkPositive 1)-        | (x, True) <- M.toList (interps tok) ]---- | Mark all interpretations with tag component beeing a member of--- the given choice set with disamb annotations.-choose :: Token -> S.Set T.Text -> Token-choose tok choice =-    tok { interps = (M.fromList . map mark . M.keys) (interps tok) }-  where-    mark ip -        | tag ip `S.member` choice  = (ip, True) -        | otherwise                 = (ip, False)---- | Add new interpretations with given disamb annotation.-addInterps :: Bool -> Token -> [Interp] -> Token-addInterps dmb tok xs =-    let newIps = M.fromList [(x, dmb) | x <- xs]-    in  tok { interps = M.unionWith max newIps (interps tok) }---- | Add new interpretations with "None" base and given disamb annotation.-addNones :: Bool -> Token -> [T.Text] -> Token-addNones dmb tok = addInterps dmb tok . map (Interp "None")--readPlain :: T.Text -> FilePath -> IO [[Token]]-readPlain ign = fmap (parsePlain ign) . L.readFile--parsePlain :: T.Text -> L.Text -> [[Token]]-parsePlain ign = map (parseSent ign) . init . L.splitOn "\n\n"--parseSent :: T.Text -> 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.fromList (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 = Interp (L.toStrict form) (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 "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 (<>) #-}--writePlain :: T.Text -> FilePath -> [[Token]] -> IO ()-writePlain ign path = L.writeFile path . showPlain ign --showPlain :: T.Text -> [[Token]] -> L.Text-showPlain ign =-    L.toLazyText . mconcat  . map (\xs -> buildSent ign xs <> "\n")--showSent :: T.Text -> [Token] -> L.Text-showSent ign = L.toLazyText . buildSent ign--showWord :: T.Text -> Token -> L.Text-showWord ign = L.toLazyText . buildWord ign--buildSent :: T.Text -> [Token] -> L.Builder-buildSent ign = mconcat . map (buildWord ign)--buildWord :: T.Text -> 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" <> L.fromText _base <>-      "\t" <> L.fromText _tag <>-      if dmb-        then "\tdisamb\n"-        else "\n"-    | (Interp _base _tag, dmb) <- interps ]--buildSpace :: Space -> L.Builder-buildSpace None     = "none"-buildSpace Space    = "space"-buildSpace NewLine  = "newline"--buildKnown :: T.Text -> Bool -> L.Builder-buildKnown _ True       = ""-buildKnown ign False    = "\tNone\t" <> L.fromText ign <> "\n"

@@ -0,0 +1,69 @@+{-# 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.2.0+version:            0.3.0 synopsis:           Morphosyntactic tagging tool based on constrained CRFs description:     A morphosyntactic tagging tool based on constrained conditional@@ -12,45 +12,63 @@ maintainer:         waszczuk.kuba@gmail.com stability:          experimental category:           Natural Language Processing-homepage:           https://github.com/kawu/concraft+homepage:           http://zil.ipipan.waw.pl/Concraft build-type:         Simple  library     build-depends:         base >= 4 && < 5+      , array       , containers       , binary       , text       , text-binary >= 0.1 && < 0.2       , vector-      , crf-chain1-constrained >= 0.1.1 && < 0.2+      , vector-binary+      , crf-chain1-constrained >= 0.1.2 && < 0.2       , monad-ox >= 0.2 && < 0.3       , sgd >= 0.2.2 && < 0.3       , tagset-positional >= 0.2 && < 0.3-      , crf-chain2-generic >= 0.1.1 && < 0.2+      , crf-chain2-generic >= 0.3 && < 0.4+      , monad-codec >= 0.2 && < 0.3+      , data-lens+      , comonad-transformers+      , temporary      exposed-modules:-        NLP.Concraft.Morphosyntax-      , NLP.Concraft.Plain+        NLP.Concraft+      , NLP.Concraft.Morphosyntax+      , NLP.Concraft.Format+      , NLP.Concraft.Format.Plain+      , NLP.Concraft.Schema       , NLP.Concraft.Guess       , NLP.Concraft.Disamb+      , NLP.Concraft.Disamb.Tiered+      , NLP.Concraft.Disamb.Positional      ghc-options: -Wall -O2  source-repository head     type: git-    location: git://github.com/kawu/concraft.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+-- 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-disamb+executable concraft     build-depends:         cmdargs     hs-source-dirs: ., tools-    main-is: concraft-disamb.hs    -    ghc-options: -Wall -O2 -threaded+    main-is: concraft.hs    +    ghc-options: -Wall -O2 -threaded -rtsopts

@@ -1,86 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}--import Control.Monad (when)-import System.Console.CmdArgs-import Data.Binary (encodeFile, decodeFile)-import Data.Text.Binary ()-import qualified Data.Set as S-import qualified Numeric.SGD as SGD-import qualified Data.Text as T-import qualified Data.Text.Lazy.IO as L--import NLP.Concraft.Disamb--tierConf :: TierConf-tierConf =-    (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" ]--data Args-  = LearnMode-    { learnPath	    :: FilePath-    , evalPath      :: Maybe FilePath-    , tagsetPath    :: FilePath-    , ignTag        :: String-    , iterNum       :: Double-    , batchSize     :: Int-    , regVar        :: Double-    , gain0         :: Double-    , tau           :: Double-    , outDisamb     :: FilePath }-  | TagMode-    { dataPath      :: FilePath-    , ignTag        :: String-    , inDisamb      :: FilePath }-  deriving (Data, Typeable, Show)--learnMode :: Args-learnMode = LearnMode-    { tagsetPath = def &= argPos 0 &= typ "TAGSET-PATH"-    , ignTag = def &= argPos 1 &= typ "IGN-TAG"-    , learnPath = def &= argPos 2 &= typ "TRAIN-FILE"-    , evalPath = def &= typFile &= help "Evaluation file"-    , 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"-    , outDisamb = def &= typFile &= help "Output Disamb file" }--tagMode :: Args-tagMode = TagMode-    { ignTag = def &= argPos 0 &= typ "IGN-TAG"-    , inDisamb = def &= argPos 1 &= typ "DISAMB-FILE"-    , dataPath = def &= argPos 2 &= typ "INPUT" }--argModes :: Mode (CmdArgs Args)-argModes = cmdArgsMode $ modes [learnMode, tagMode]--main :: IO ()-main = exec =<< cmdArgsRun argModes--exec :: Args -> IO ()--exec LearnMode{..} = do-    dmb <- learn sgdArgs tagsetPath (T.pack ignTag) tierConf learnPath evalPath-    when (not . null $ outDisamb) $ do-        putStrLn $ "\nSaving model in " ++ outDisamb ++ "..."-        encodeFile outDisamb dmb-  where-    sgdArgs = SGD.SgdArgs-        { SGD.batchSize = batchSize-        , SGD.regVar = regVar-        , SGD.iterNum = iterNum-        , SGD.gain0 = gain0-        , SGD.tau = tau }--exec TagMode{..} = do-    dmb <- decodeFile inDisamb-    L.putStr =<< tagFile (T.pack ignTag) dmb dataPath

@@ -1,74 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}--import Control.Monad (when)-import System.Console.CmdArgs-import Data.Binary (encodeFile, decodeFile)-import Data.Text.Binary ()-import qualified Numeric.SGD as SGD-import qualified Data.Text as T-import qualified Data.Text.Lazy.IO as L--import NLP.Concraft.Guess (learn, tagFile)--data Args-  = LearnMode-    { learnPath	    :: FilePath-    , evalPath      :: Maybe FilePath-    , ignTag        :: String-    , iterNum       :: Double-    , batchSize     :: Int-    , regVar        :: Double-    , gain0         :: Double-    , tau           :: Double-    , outGuesser    :: FilePath }-  | TagMode-    { dataPath      :: FilePath-    , inGuesser     :: FilePath-    , guessNum      :: Int }-  deriving (Data, Typeable, Show)--learnMode :: Args-learnMode = LearnMode-    { ignTag = def &= argPos 0 &= typ "IGN-TAG"-    , learnPath = def &= argPos 1 &= typ "TRAIN-FILE"-    , evalPath = def &= typFile &= help "Evaluation file"-    , 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"-    , outGuesser = def &= typFile &= help "Output Guesser file" }--tagMode :: Args-tagMode = TagMode-    { inGuesser = def &= argPos 0 &= typ "GUESSER-FILE"-    , dataPath = def &= argPos 1 &= typ "INPUT"-    , guessNum = 10 &= help "Number of guessed tags for each unknown word" }--argModes :: Mode (CmdArgs Args)-argModes = cmdArgsMode $ modes [learnMode, tagMode]--main :: IO ()-main = exec =<< cmdArgsRun argModes--exec :: Args -> IO ()--exec LearnMode{..} = do-    gsr <- learn sgdArgs (T.pack ignTag) learnPath evalPath-    when (not . null $ outGuesser) $ do-        putStrLn $ "\nSaving model in " ++ outGuesser ++ "..."-        encodeFile outGuesser gsr-  where-    sgdArgs = SGD.SgdArgs-        { SGD.batchSize = batchSize-        , SGD.regVar = regVar-        , SGD.iterNum = iterNum-        , SGD.gain0 = gain0-        , SGD.tau = tau }--exec TagMode{..} = do-    gsr <- decodeFile inGuesser-    L.putStr =<< tagFile guessNum gsr dataPath

@@ -0,0 +1,151 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}++import Control.Applicative ((<$>), (<*>))+import Control.Monad (when)+import System.Console.CmdArgs+import Data.Binary (Binary, put, get, encodeFile, decodeFile)+import Data.Text.Binary ()+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.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++-- | 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+    , 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 = def &= 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 = def &= 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+    (guesser', disambModel') <- case format of+        Plain   -> doTrain (plainFormat ign) tagset'+    let concraftData = ConcraftData+            { guesser       = guesser'+            , disambModel   = disambModel'+            , tagset        = tagset'+            , tierConf      = D.tierConfDefault }+    when (not . null $ outModel) $ do+        putStrLn $ "\nSaving model in " ++ outModel ++ "..."+        encodeFile outModel concraftData+  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+    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+    doTag <- doTagWith <$> decodeFile inModel <*> L.getContents+    case format of+        Plain   -> L.putStr $ doTag (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+    ign = T.pack ignTag