diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/concraft-pl.cabal b/concraft-pl.cabal new file mode 100644 --- /dev/null +++ b/concraft-pl.cabal @@ -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 diff --git a/src/NLP/Concraft/Polish.hs b/src/NLP/Concraft/Polish.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Polish.hs @@ -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) diff --git a/src/NLP/Concraft/Polish/Format/Plain.hs b/src/NLP/Concraft/Polish/Format/Plain.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Polish/Format/Plain.hs @@ -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 #-} diff --git a/src/NLP/Concraft/Polish/Maca.hs b/src/NLP/Concraft/Polish/Maca.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Polish/Maca.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +-- | The module provides interface for the Maca analysis tool. +-- See +-- 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 diff --git a/src/NLP/Concraft/Polish/Morphosyntax.hs b/src/NLP/Concraft/Polish/Morphosyntax.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Polish/Morphosyntax.hs @@ -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) ] diff --git a/src/NLP/Concraft/Polish/Server.hs b/src/NLP/Concraft/Polish/Server.hs new file mode 100644 --- /dev/null +++ b/src/NLP/Concraft/Polish/Server.hs @@ -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 diff --git a/tools/concraft-pl.hs b/tools/concraft-pl.hs new file mode 100644 --- /dev/null +++ b/tools/concraft-pl.hs @@ -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