packages feed

concraft-pl (empty) → 0.1.0

raw patch · 9 files changed

+1173/−0 lines, 9 filesdep +aesondep +basedep +binarysetup-changed

Dependencies added: aeson, base, binary, bytestring, cmdargs, concraft, containers, mtl, network, process, sgd, tagset-positional, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2013 Jakub Waszczuk+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ concraft-pl.cabal view
@@ -0,0 +1,55 @@+name:               concraft-pl+version:            0.1.0+synopsis:           Morphological tagger for Polish+description:+    A morphological tagger for Polish based on the concraft library.+license:            BSD3+license-file:       LICENSE+cabal-version:      >= 1.6+copyright:          Copyright (c) 2013 Jakub Waszczuk+author:             Jakub Waszczuk+maintainer:         waszczuk.kuba@gmail.com+stability:          experimental+category:           Natural Language Processing+homepage:           http://zil.ipipan.waw.pl/Concraft+build-type:         Simple++library+    hs-source-dirs: src++    build-depends:+        base >= 4 && < 5+      , concraft >= 0.5 && < 0.6+      , tagset-positional >= 0.3 && < 0.4+      , sgd >= 0.2.2 && < 0.3+      , containers+      , bytestring+      , text+      , aeson >= 0.6 && < 0.7+      , binary+      , process+      , mtl+      , transformers+      , network++    exposed-modules:+        NLP.Concraft.Polish+      , NLP.Concraft.Polish.Maca+      , NLP.Concraft.Polish.Morphosyntax+      , NLP.Concraft.Polish.Server++    other-modules:+        NLP.Concraft.Polish.Format.Plain++    ghc-options: -Wall -O2++source-repository head+    type: git+    location: https://github.com/kawu/concraft-pl.git++executable concraft-pl+    build-depends:+        cmdargs >= 0.10 && < 0.11+    hs-source-dirs: src, tools+    main-is: concraft-pl.hs    +    ghc-options: -Wall -O2 -threaded -rtsopts
+ src/NLP/Concraft/Polish.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings #-}+++module NLP.Concraft.Polish+(+-- * Model+  C.Concraft+, C.saveModel+, C.loadModel++-- * Tagging+, tag+, tag'+, tagSent++-- * Training+, train+) where+++import           System.IO.Unsafe (unsafeInterleaveIO)+import           Control.Applicative ((<$>))+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Set as S+import qualified Data.Tagset.Positional as P+import qualified Numeric.SGD as SGD++import qualified NLP.Concraft.Schema as S+import           NLP.Concraft.Schema (SchemaConf(..), entry, entryWith)+import qualified NLP.Concraft.Guess as G+import qualified NLP.Concraft.Disamb as D+import qualified NLP.Concraft as C++import           NLP.Concraft.Polish.Morphosyntax hiding (tag)+import           NLP.Concraft.Polish.Maca+++-------------------------------------------------+-- Default configuration+-------------------------------------------------+++-- | Default configuration for the guessing observation schema.+guessConfDefault :: SchemaConf+guessConfDefault = S.nullConf+    { lowPrefixesC  = entryWith [1, 2]      [0]+    , lowSuffixesC  = entryWith [1, 2]      [0]+    , knownC        = entry                 [0]+    , begPackedC    = entry                 [0] }+++-- | Default configuration for the guessing observation schema.+disambConfDefault :: SchemaConf+disambConfDefault = S.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 { S.oovOnly = True }+    oov Nothing     = Nothing+++-- | Default tiered tagging configuration.+tiersDefault :: [D.Tier]+tiersDefault =+    [tier1, tier2]+  where+    tier1 = D.Tier True $ S.fromList ["cas", "per"]+    tier2 = D.Tier False $ S.fromList+        [ "nmb", "gnd", "deg", "asp" , "ngt", "acm"+        , "acn", "ppr", "agg", "vlc", "dot" ]+++-------------------------------------------------+-- Tagging+-------------------------------------------------+++-- | Perform morphological tagging on the input text.+tag :: MacaPool -> C.Concraft -> T.Text -> IO [Sent Tag]+tag pool concraft inp = map (tagSent concraft) <$> macaPar pool inp+++-- | An alernative tagging function which interprets+-- empty lines as paragraph ending markers.+-- The function uses lazy IO so it can be used to+-- analyse large chunks of data.+tag' :: MacaPool -> C.Concraft -> L.Text -> IO [[Sent Tag]]+tag' pool concraft+    = lazyMapM (tag pool concraft . L.toStrict)+    . map L.strip+    . L.splitOn "\n\n"+++-- | Tag an already analysed sentence.+tagSent :: C.Concraft -> Sent Tag -> Sent Tag+tagSent concraft inp =+    let tagset = C.tagset concraft+        packed = packSentTag tagset inp+        xs = C.tag concraft packed+    in  embedSent inp $ map (P.showTag tagset) xs+++lazyMapM :: (a -> IO b) -> [a] -> IO [b]+lazyMapM f (x:xs) = do+    y <- f x+    ys <- unsafeInterleaveIO $ lazyMapM f xs+    return (y:ys)+lazyMapM _ [] = return []+++-------------------------------------------------+-- Training+-------------------------------------------------+++-- | Train concraft model.+-- TODO: It should be possible to supply the two training procedures with+-- different SGD arguments.+train+    :: SGD.SgdArgs      -- ^ SGD parameters+    -> P.Tagset         -- ^ Tagset+    -> Int              -- ^ Numer of guessed tags for each word +    -> [SentO Tag]      -- ^ Training data+    -> Maybe [SentO Tag] -- ^ Maybe evaluation data+    -> IO C.Concraft+train sgdArgs tagset guessNum train0 eval0 = do+    pool <- newMacaPool 1+    let guessConf  = G.TrainConf guessConfDefault sgdArgs+        disambConf = D.TrainConf tiersDefault disambConfDefault sgdArgs+        ana = fmap (packSentTag tagset . concat) . macaPar pool . L.toStrict+    C.train tagset ana guessNum guessConf disambConf+        (map (packSentTagO tagset)     train0)+        (map (packSentTagO tagset) <$> eval0)
+ src/NLP/Concraft/Polish/Format/Plain.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Simple format for morphosyntax representation which+-- assumes that all tags have a textual representation+-- with no spaces within and that one of the tags indicates+-- unknown words.++module NLP.Concraft.Polish.Format.Plain+(+-- * Parsing+  parsePlain+, parsePlainO+, parsePar+, parseSent++-- * Printing+, showPlain+, showPar+, showSent+) where++import           Data.Monoid (Monoid, mappend, mconcat)+import           Data.Maybe (catMaybes)+import           Data.List (groupBy)+import           Data.String (IsString)+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           NLP.Concraft.Polish.Morphosyntax++noneBase :: T.Text+noneBase = "None"++-- | Parse the text in the plain format given the /oov/ tag.+-- Original sentences will be restored using the `withOrig`+-- function.  Plain format doesn't preserve original,+-- textual representation of individual sentences.+parsePlainO :: L.Text -> [[SentO Tag]]+parsePlainO = map (map withOrig) . parsePlain++-- | Parse the text in the plain format given the /oov/ tag.+-- TODO: Handling spaces between paragraphs and sentences has to be+-- smarter than that.+parsePlain :: L.Text -> [[Sent Tag]]+parsePlain = map parsePar . filter (not.L.null) . L.splitOn "\n\n\n"++parsePar :: L.Text -> [Sent Tag]+parsePar = map parseSent . filter (not.L.null) . L.splitOn "\n\n"++-- | Parse the sentence in the plain format given the /oov/ tag.+parseSent :: L.Text -> Sent Tag+parseSent+    = map parseWord+    . groupBy (\_ x -> cond x)+    . L.lines+  where+    cond = ("\t" `L.isPrefixOf`)++parseWord :: [L.Text] -> Seg Tag+parseWord xs = Seg+    (Word _orth _space _known)+    _interps+  where+    (_orth, _space) = parseHeader (head xs)+    ys          = map parseInterp (tail xs)+    _known      = not (Nothing `elem` ys)+    _interps    = M.fromListWith max (catMaybes ys)++parseInterp :: L.Text -> Maybe (Interp Tag, Bool)+parseInterp =+    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+-----------++-- | Show the plain data.+showPlain :: [[Sent Tag]] -> L.Text+showPlain =+    L.intercalate "\n" . map showPar++-- | Show the paragraph.+showPar :: [Sent Tag] -> L.Text+showPar = L.toLazyText . mconcat  . map (\xs -> buildSent xs <> "\n")++-- | Show the sentence.+showSent :: Sent Tag -> L.Text+showSent xs = L.toLazyText $ buildSent xs++buildSent :: Sent Tag -> L.Builder+buildSent = mconcat . map buildWord++buildWord :: Seg Tag -> L.Builder+buildWord Seg{..}+    =  L.fromText orth  <> "\t"+    <> buildSpace space <> "\n"+    <> buildKnown known+    <> buildInterps (M.toList interps)+    where Word{..} = word++buildInterps :: [(Interp Tag, 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 :: Bool -> L.Builder+buildKnown True  = ""+buildKnown False =  "\t" <> L.fromText noneBase+                         <> "\t" <> L.fromText ign <> "\n"+++-----------+-- Utils+-----------+++-- | An infix synonym for 'mappend'.+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+{-# INLINE (<>) #-}+++-- | Tag which indicates unknown words.+ign :: IsString a => a+ign = "ign"+{-# INLINE ign #-}
+ src/NLP/Concraft/Polish/Maca.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+++-- | The module provides interface for the Maca analysis tool.+-- See <http://nlp.pwr.wroc.pl/redmine/projects/libpltagger/wiki>+-- for more information about the analyser.+++module NLP.Concraft.Polish.Maca+(+  MacaPool+, newMacaPool+, macaPar+) where+++import           Control.Applicative ((<$>))+import           Control.Monad (void, forever, guard, replicateM)+import           Control.Concurrent+import           Control.Exception+import           System.Process+import           System.IO+import           Data.Function (on)+import qualified Data.Char as C+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L+import qualified Control.Monad.State.Strict as S+import qualified Control.Monad.Trans.Maybe as M+import           Control.Monad.Trans.Class (lift)++import           NLP.Concraft.Polish.Morphosyntax hiding (restore)+import qualified NLP.Concraft.Polish.Format.Plain as Plain+++----------------------------+-- Maca instance+----------------------------+++-- TODO: We don't have to use channels here.  Maximum one element+-- should be present in the input/output channel.+    ++-- | Input channel.+type In = Chan T.Text+++-- | Output channel.+type Out = Chan [Sent Tag]+++-- | Maca communication channels.+newtype Maca = Maca (In, Out)+++-- | Run Maca instance.+newMaca :: IO Maca+newMaca = do+    inCh  <- newChan+    outCh <- newChan+    void $ runMacaOn inCh outCh+    return $ Maca (inCh, outCh)+++-- | Run Maca server on given channels.+-- TODO: Should check, if maca works.  In particular, if morfeusz is available.+runMacaOn :: In -> Out -> IO ThreadId+runMacaOn inCh outCh = forkIO . mask $ \restore -> do+    let cmd  = "maca-analyse"+        args = ["-q", "morfeusz-nkjp-official", "-o", "plain", "-l"]+    (Just inh, Just outh, Just errh, pid) <-+        createProcess (proc cmd args){ std_in  = CreatePipe+                                     , std_out = CreatePipe+                                     , std_err = CreatePipe }++    let excHandler = do+            -- TODO: Is it possible, that `errh` handle is closed?+            -- If so, appropriate exception should be handled.+            err <- hGetContents errh+            putStr "Maca error: " >> putStrLn err+            hClose inh; hClose outh; hClose errh+            terminateProcess pid+            waitForProcess pid++    -- TODO: Document, why LineBuffering is needed here.+    hSetBuffering outh LineBuffering+    flip onException excHandler $ restore $ forever $ do++        -- Take element from the input channel.+        txt <- readChan inCh+        -- putStr "REQUEST: "+        -- print txt++        -- Write text to maca stdin.+        -- TODO: Handle the "empty" case?+        T.hPutStr inh txt; hFlush inh++        -- Read maca response and put it in the output channel.+        writeChan outCh =<< readMacaResponse outh (textWeight txt)+++readMacaResponse :: Handle -> Int -> IO [Sent Tag]+readMacaResponse h n+    | n <= 0    = return []+    | otherwise = do+        x  <- readMacaSent h+        xs <- readMacaResponse h (n - sentWeight x)+        return (x : xs)+++readMacaSent :: Handle -> IO (Sent Tag)+readMacaSent h =+    Plain.parseSent <$> getTxt +  where+    getTxt = do+        x <- L.hGetLine h+        if L.null x+            then return x+            else do   +                xs <- getTxt+                return (x `L.append` "\n" `L.append` xs)+++----------------------------+-- Client+----------------------------+    ++-- | Analyse paragraph with Maca.+doMacaPar :: Maca -> T.Text -> IO [Sent Tag]+doMacaPar (Maca (inCh, outCh)) par = do+    let par' = T.intercalate "  " (T.lines par) `T.append` "\n"+    writeChan inCh par'+    restoreSpaces par <$> readChan outCh+++-- | Restore info abouts spaces from a text and insert them+-- to a parsed paragraph.+restoreSpaces :: T.Text -> [Sent Tag] -> [Sent Tag]+restoreSpaces par sents =+    S.evalState (mapM onSent sents) (0, chunks)+  where+    -- For each space chunk in the paragraph compute+    -- total weight of earlier chunks.+    parts   = T.groupBy ((==) `on` C.isSpace) par+    weights = scanl1 (+) (map textWeight parts)+    chunks  = filter (T.any C.isSpace . fst) (zip parts weights)++    -- Stateful monadic computation which modifies spaces+    -- assigned to individual segments.+    onSent = mapM onWord+    onWord seg = do+        n <- addWeight seg+        s <- popSpace n+        let word' = (word seg) { space = s }+        return $ seg { word = word' }++    -- Add weight of the segment to the current weight.+    addWeight seg = S.state $ \(n, xs) ->+        let m = n + segWeight seg+        in (m, (m, xs))++    -- Pop space from the stack if its weight is lower than+    -- the current one.+    popSpace n = fmap (maybe None id) . M.runMaybeT $ do+        spaces  <- lift $ S.gets snd+        (sp, m) <- liftMaybe $ maybeHead spaces+        guard $ m < n+        lift $ S.modify $ \(n', xs) -> (n', tail xs)+        return $ toSpace sp+    liftMaybe = M.MaybeT . return+    maybeHead xs = case xs of+        (x:_)   -> Just x+        []      -> Nothing++    -- Parse strings representation of a Space.+    toSpace x+        | has '\n'  = NewLine +        | has ' '   = Space +        | otherwise = None+        where has c = maybe False (const True) (T.find (==c) x)+++----------------------------+-- Pool+----------------------------+++-- | A pool of Maca instances.+newtype MacaPool = MacaPool (Chan Maca)+++-- | Run Maca server.+newMacaPool+    :: Int          -- ^ Number of Maca instances+    -> IO MacaPool+newMacaPool n = do+    chan  <- newChan+    macas <- replicateM n newMaca+    writeList2Chan chan macas+    return $ MacaPool chan+++popMaca :: MacaPool -> IO Maca+popMaca (MacaPool c) = readChan c+++putMaca :: Maca -> MacaPool -> IO ()+putMaca x (MacaPool c) = writeChan c x+++-- | Analyse paragraph with Maca.+-- The function is thread-safe.+macaPar :: MacaPool -> T.Text -> IO [Sent Tag]+macaPar pool par = do+    maca <- popMaca pool+    doMacaPar maca par `finally` putMaca maca pool+++----------------------------+-- Weight+----------------------------+++-- | A number of non-space characters in a text.+textWeight :: T.Text -> Int+textWeight = T.length . T.filter (not . C.isSpace)+++-- | A number of non-space characters in a sentence.+segWeight :: Seg t -> Int+segWeight = textWeight . orth . word+++-- | A number of non-space characters in a sentence.+sentWeight :: Sent t -> Int+sentWeight = sum . map segWeight
+ src/NLP/Concraft/Polish/Morphosyntax.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++-- | Morphosyntax data layer in Polish.++module NLP.Concraft.Polish.Morphosyntax+( +-- * Tag+  Tag++-- * Segment +, Seg (..)+, Word (..)+, Interp (..)+, Space (..)++-- * Sentence+, Sent+, SentO (..)+, restore+, withOrig++-- * Conversion+, packSegTag+, packSeg+, packSentTag+, packSentTagO+, packSent+, embedSent+) where++import           Control.Applicative ((<$>), (<*>))+import           Control.Arrow (first)+import           Data.Maybe (catMaybes)+import           Data.Aeson+import           Data.Binary (Binary, put, get, putWord8, getWord8)+import qualified Data.Aeson as Aeson+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.Tagset.Positional as P++import qualified NLP.Concraft.Morphosyntax as X++-- | A textual representation of a morphosyntactic tag.+type Tag = T.Text++--------------------------------+-- Segment+--------------------------------++-- | A segment.+data Seg t = Seg +    { word      :: Word+    -- | 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 t) Bool }+    deriving (Show, Eq, Ord)++instance (Ord t, Binary t) => Binary (Seg t) where+    put Seg{..} = put word >> put interps+    get = Seg <$> get <*> get++-- | A word.+data Word = Word+    { orth      :: T.Text+    , space     :: Space+    , known     :: Bool }+    deriving (Show, Eq, Ord)++instance X.Word Word where+    orth = orth+    oov = not.known++instance ToJSON Word where+    toJSON Word{..} = object+        [ "orth"  .= orth+        , "space" .= space+        , "known" .= known ]++instance FromJSON Word where+    parseJSON (Object v) = Word+        <$> v .: "orth"+        <*> v .: "space"+        <*> v .: "known"+    parseJSON _ = error "parseJSON [Word]"++instance Binary Word where+    put Word{..} = put orth >> put space >> put known+    get = Word <$> get <*> get <*> get+    +-- | An interpretation.+-- TODO: Should we allow `base` to be `Nothing`?+data Interp t = Interp+    { base  :: Maybe T.Text+    , tag   :: t }+    deriving (Show, Eq, Ord)++instance (Ord t, Binary t) => Binary (Interp t) where+    put Interp{..} = put base >> put tag+    get = Interp <$> get <*> get++-- | No space, space or newline.+-- TODO: Perhaps we should use a bit more informative data type.+data Space+    = None+    | Space+    | NewLine+    deriving (Show, Eq, Ord)++instance Binary Space where+    put x = case x of+        None    -> putWord8 1+        Space   -> putWord8 2+        NewLine -> putWord8 3+    get = getWord8 >>= \x -> return $ case x of+        1   -> None+        2   -> Space+        _   -> NewLine++instance ToJSON Space where+    toJSON x = Aeson.String $ case x of+        None    -> "none"+        Space   -> "space"+        NewLine -> "newline"++instance FromJSON Space where+    parseJSON (Aeson.String x) = return $ case x of+        "none"      -> None+        "space"     -> Space+        "newline"   -> NewLine+        _           -> error "parseJSON [Space]"+    parseJSON _ = error "parseJSON [Space]"++--------------------------------+-- Sentence+--------------------------------++-- | A sentence.+type Sent t = [Seg t]++-- | A sentence.+data SentO t = SentO+    { segs  :: [Seg t]+    , orig  :: L.Text }++-- | Restore textual representation of a sentence.+-- The function is not very accurate, it could be improved+-- if we enrich representation of a space.+restore :: Sent t -> L.Text+restore =+    let wordStr Word{..} = [spaceStr space, orth] +        spaceStr None       = ""+        spaceStr Space      = " "+        spaceStr NewLine    = "\n"+    in  L.fromChunks . concatMap (wordStr . word)++-- | Use `restore` to translate `Sent` to a `SentO`.+withOrig :: Sent t -> SentO t+withOrig s = SentO+    { segs = s+    , orig = restore s }++---------------------------+-- Conversion+---------------------------++-- | Convert a segment to a segment from a core library.+packSegTag :: P.Tagset -> Seg Tag -> X.Seg Word P.Tag+packSegTag tagset = X.mapSeg (P.parseTag tagset) . packSeg++-- | Convert a segment to a segment from a core library.+packSeg :: Ord a => Seg a -> X.Seg Word a+packSeg Seg{..} = X.Seg word $ X.mkWMap+    [ (tag x, if disamb then 1 else 0)+    | (x, disamb) <- M.toList interps ]++-- | Convert a sentence to a sentence from a core library.+packSentTag :: P.Tagset -> Sent Tag -> X.Sent Word P.Tag+packSentTag = map . packSegTag++-- | Convert a sentence to a sentence from a core library.+packSentTagO :: P.Tagset -> SentO Tag -> X.SentO Word P.Tag+packSentTagO tagset s = X.SentO+    { segs = packSentTag tagset (segs s)+    , orig = orig s }++-- | Convert a sentence to a sentence from a core library.+packSent :: Ord a => Sent a -> X.Sent Word a+packSent = map packSeg++-- | Embed tags in a sentence.+embedSent :: Ord a => Sent a -> [a] -> Sent a+embedSent sent xs = [selectOne x seg | (x, seg) <- zip xs sent]++-- | Select one interpretation.+selectOne :: Ord a => a -> Seg a -> Seg a+selectOne x = select (X.mkWMap [(x, 1)])++-- | Select interpretations.+select :: Ord a => X.WMap a -> Seg a -> Seg a+select wMap seg =+    seg { 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) (X.unWMap wMap) of+            Just x  -> (interp, asDmb x)+            Nothing -> (interp, False)+        | interp <- M.keys (interps seg) ]+            ++ catMaybes+        [ if tag `M.member` wSet seg+            then Nothing+            else Just (Interp Nothing tag, asDmb x)+        | (tag, x) <- M.toList (X.unWMap wMap) ]
+ src/NLP/Concraft/Polish/Server.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings #-}+++module NLP.Concraft.Polish.Server+( +-- * Server+  runConcraftServer++-- * Client+, tag+, tag'+) where+++import           Control.Applicative ((<$>))+import           Control.Monad (forever, void)+import           Control.Concurrent (forkIO)+import           System.IO (Handle, hFlush)+import           System.IO.Unsafe (unsafeInterleaveIO)+import qualified Network as N+import qualified Data.Binary as B+import qualified Data.ByteString.Lazy as BS+import qualified Data.Text as T+import qualified Data.Text.Lazy as L++import           NLP.Concraft.Polish.Morphosyntax hiding (tag)+import           NLP.Concraft.Polish.Maca+import qualified NLP.Concraft.Polish as C+++-------------------------------------------------+-- Server+-------------------------------------------------+++-- | Run a Concraft server on a given port.+runConcraftServer :: MacaPool -> C.Concraft -> N.PortID -> IO ()+runConcraftServer pool concraft port = N.withSocketsDo $ do+    sock <- N.listenOn port+    forever $ sockHandler pool concraft sock+++sockHandler :: MacaPool -> C.Concraft -> N.Socket -> IO ()+sockHandler pool concraft sock = do+    (handle, _, _) <- N.accept sock+    -- putStrLn "Connection established"+    void $ forkIO $ do+        -- putStrLn "Waiting for input..."+        inp <- recvMsg handle+        -- putStr "> " >> T.putStrLn inp+        out <- C.tag pool concraft inp+        -- putStr "No. of sentences: " >> print (length out)+        sendMsg handle out+++-------------------------------------------------+-- Client+-------------------------------------------------+++-- | Perform morphological tagging on the input text.+tag :: N.HostName -> N.PortID -> T.Text -> IO [Sent Tag]+tag host port inp = do+    handle <- N.connectTo host port+    -- putStrLn "Connection established"+    -- putStr "Send request: " >> T.putStrLn inp+    sendMsg handle inp+    recvMsg handle+++-- | An alernative tagging function which interprets+-- empty lines as paragraph ending markers.+-- The function uses lazy IO so it can be used to+-- analyse large chunks of data.+tag' :: N.HostName -> N.PortID -> L.Text -> IO [[Sent Tag]]+tag' host port+    = lazyMapM (tag host port . L.toStrict)+    . map L.strip+    . L.splitOn "\n\n"+++lazyMapM :: (a -> IO b) -> [a] -> IO [b]+lazyMapM f (x:xs) = do+    y <- f x+    ys <- unsafeInterleaveIO $ lazyMapM f xs+    return (y:ys)+lazyMapM _ [] = return []+++-------------------------------------------------+-- Messages+-------------------------------------------------+++sendMsg :: B.Binary a => Handle -> a -> IO ()+sendMsg h msg = do+    let x = B.encode msg+        n = fromIntegral $ BS.length x+    sendInt h n+    BS.hPut h x+    hFlush h+++recvMsg :: B.Binary a => Handle -> IO a+recvMsg h = do+    n <- recvInt h+    B.decode <$> BS.hGet h n+++sendInt :: Handle -> Int -> IO ()+sendInt h x = BS.hPut h (B.encode x)+++recvInt :: Handle -> IO Int+recvInt h = B.decode <$> BS.hGet h 8+    ++-- -------------------------------------------------+-- -- Stream binary encoding+-- -------------------------------------------------+-- +-- +-- newtype Stream a = Stream { unstream :: [a] }+-- +-- +-- instance B.Binary a => B.Binary (Stream a) where+--     put (Stream [])     = B.putWord8 0+--     put (Stream (x:xs)) = B.putWord8 1 >> B.put x >> B.put (Stream xs)+--     get = error "use lazyDecodeStream insted"+-- +-- +-- getMaybe :: B.Binary a => B.Get (Maybe a)+-- getMaybe = do+--     t <- B.getWord8+--     case t of+--         0 -> return Nothing+--         _ -> fmap Just B.get+-- +-- +-- step :: B.Binary a => (ByteString, Int64) -> Maybe (a, (ByteString, Int64))+-- step (xs, offset) = case B.runGetState getMaybe xs offset of+--     (Just v, ys, newOffset) -> Just (v, (ys, newOffset))+--     _                       -> Nothing+-- +-- +-- lazyDecodeList :: B.Binary a => ByteString -> [a]+-- lazyDecodeList xs = unfoldr step (xs, 0)+-- +-- +-- lazyDecodeStream :: B.Binary a => ByteString -> Stream a+-- lazyDecodeStream = Stream . lazyDecodeList
+ tools/concraft-pl.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+++import           Control.Applicative ((<$>))+import           Control.Monad (unless)+import           System.Console.CmdArgs+import           System.IO (hFlush, stdout)+import qualified Network as N+import qualified Numeric.SGD as SGD+import qualified Data.Text.Lazy as L+import qualified Data.Text.Lazy.IO as L+import           Data.Tagset.Positional (parseTagset)+import           GHC.Conc (numCapabilities)++import qualified NLP.Concraft.Polish.Maca as Maca+import qualified NLP.Concraft.Polish as C+import qualified NLP.Concraft.Polish.Server as S+import qualified NLP.Concraft.Polish.Morphosyntax as X+import qualified NLP.Concraft.Polish.Format.Plain as P+++-- | Default port number.+portDefault :: Int+portDefault = 10089+++---------------------------------------+-- Command line options+---------------------------------------+++-- | Data formats. +data Format = Plain deriving (Data, Typeable, Show)+++data Concraft+  = Train+    { trainPath	    :: FilePath+    , evalPath      :: Maybe FilePath+    , format        :: Format+    , tagsetPath    :: FilePath+    -- , discardHidden :: Bool+    , iterNum       :: Double+    , batchSize     :: Int+    , regVar        :: Double+    , gain0         :: Double+    , tau           :: Double+    , outModel      :: FilePath+    , guessNum      :: Int }+  | Tag+    { inModel       :: FilePath+    , format        :: Format }+    -- , guessNum      :: Int }+  | Server+    { inModel       :: FilePath+    , port          :: Int }+  | Client+    { format        :: Format+    , host          :: String+    , port          :: 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"]+    -- , 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" }+++tagMode :: Concraft+tagMode = Tag+    { inModel = def &= argPos 0 &= typ "MODEL-FILE"+    , format  = enum [Plain &= help "Use plain format for output"] }+    -- , guessNum = 10 &= help "Number of guessed tags for each unknown word" }+++serverMode :: Concraft+serverMode = Server+    { inModel = def &= argPos 0 &= typ "MODEL-FILE"+    , port    = portDefault &= help "Port number" }+++clientMode :: Concraft+clientMode = Client+    { port   = portDefault &= help "Port number"+    , host   = "localhost" &= help "Server host name"+    , format = enum [Plain &= help "Use plain format for output"] }+++argModes :: Mode (CmdArgs Concraft)+argModes = cmdArgsMode $ modes [trainMode, tagMode, serverMode, clientMode]+++---------------------------------------+-- Main+---------------------------------------+++main :: IO ()+main = exec =<< cmdArgsRun argModes+++exec :: Concraft -> IO ()+++exec Train{..} = do+    tagset <- parseTagset tagsetPath <$> readFile tagsetPath+    train0 <- parseData  format trainPath+    eval0  <- parseData' format evalPath+    concraft <- C.train sgdArgs tagset guessNum train0 eval0 +    unless (null outModel) $ do+        putStrLn $ "\nSaving model in " ++ outModel ++ "..."+        C.saveModel outModel concraft+  where+    sgdArgs = SGD.SgdArgs+        { SGD.batchSize = batchSize+        , SGD.regVar = regVar+        , SGD.iterNum = iterNum+        , SGD.gain0 = gain0+        , SGD.tau = tau }+++exec Tag{..} = do+    concraft <- C.loadModel inModel+    pool <- Maca.newMacaPool numCapabilities+    out <- C.tag' pool concraft =<< L.getContents+    L.putStr $ showData format out+++exec Server{..} = do+    putStr "Loading model..." >> hFlush stdout+    concraft <- C.loadModel inModel+    putStrLn " done"+    pool <- Maca.newMacaPool numCapabilities+    let portNum = N.PortNumber $ fromIntegral port+    putStrLn $ "Listening on port " ++ show port+    S.runConcraftServer pool concraft portNum+++exec Client{..} = do+    let portNum = N.PortNumber $ fromIntegral port+    out <- S.tag' host portNum =<< L.getContents+    L.putStr $ showData format out+++---------------------------------------+-- Parsing and showing+---------------------------------------+++parseData' :: Format -> Maybe FilePath -> IO (Maybe [X.SentO X.Tag])+parseData' format path = case path of+    Nothing -> return Nothing+    Just pt -> Just <$> parseData format pt+++parseData :: Format -> FilePath -> IO [X.SentO X.Tag]+parseData Plain path = concat . P.parsePlainO <$> L.readFile path+++showData :: Format -> [[X.Sent X.Tag]] -> L.Text+showData Plain = P.showPlain