diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Eric Kow + +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. + + * Neither the name of Eric Kow nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +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/NLP/Brillig.hs b/NLP/Brillig.hs new file mode 100644 --- /dev/null +++ b/NLP/Brillig.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} + +module NLP.Brillig where + +import Control.Arrow ( second, (***) ) +import qualified Data.Text as T +import qualified Data.Map as Map +import Data.Text ( Text ) + +newtype Tag = Tag { fromTag :: Text } deriving (Ord, Eq) + +instance Show Tag where + show = show . fromTag + +type Tagged a = (a, Tag) + +type Count = Map.Map Text (Map.Map Tag Int) + +readTag :: Text -> (Text, Tag) +readTag = (T.init *** Tag) . T.breakOnEnd "/" + +showTag :: Tagged Text -> Text +showTag (w,t) = T.concat [ w, "/", fromTag t] + +retag :: ([Tag] -> [Tag]) -> [Tagged Text] -> [Tagged Text] +retag f ts = zipWith replace newtags ts + where + newtags = f (map snd ts) + replace t2 (w,_) = (w, t2) diff --git a/NLP/Brillig/Brill.hs b/NLP/Brillig/Brill.hs new file mode 100644 --- /dev/null +++ b/NLP/Brillig/Brill.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} + +module NLP.Brillig.Brill where + +import Control.Arrow ( first, second, (***) ) +import Data.Function ( on ) +import qualified Data.Text as T +import qualified Data.Map as Map +import Data.List ( isPrefixOf, delete, maximumBy, sort, sortBy ) +import Data.Ord ( compare ) +import Data.Map ( Map ) +import Data.Text ( Text ) + +import qualified Data.List.Zipper as Z +import Data.List.Zipper ( Zipper ) + +import qualified Data.Set as Set +import Data.Set ( Set ) + +import NLP.Brillig +import NLP.Brillig.Util + +data Transform = Transform { context :: [Tag] -- backwards list! + , replace :: Replacement + , tscore :: Int + } + deriving (Ord, Eq) + +instance Show Transform where + show (Transform c (Replacement f t) i) = + unwords $ twords ++ [show i] + where + twords = map (T.unpack . fromTag) (reverse c ++ [f,t]) + +instance Read Transform where + readsPrec p s = + case reverse (words s) of + (i:t:f:ctx) -> + case readsPrec p i of + [(s,"")] -> [ (Transform (map toTag ctx) (repl f t) s, "") ] + _ -> [] + _ -> [] + where + repl f t = Replacement (toTag f) (toTag t) + toTag = Tag . T.pack + +data Replacement = Replacement { from :: Tag + , to :: Tag + } + deriving (Show, Ord, Eq) + +type TCount = Map Tag Int + +data TagPair = TagPair { proposed :: Tag + , actual :: Tag + } + deriving (Ord, Eq) + +-- ---------------------------------------------------------------------- +-- tag +-- ---------------------------------------------------------------------- + +brilltag :: [Transform] -> [Tagged Text] -> [Tagged Text] +brilltag rules_ = retag (\ts -> foldr tagOne ts rules) + where + rules = sortBy (flip compare `on` tscore) rules_ + +-- | Apply a single transformation +tagOne :: Transform -> [Tag] -> [Tag] +tagOne x = Z.toList . walk . Z.fromList + where + from_ = from (replace x) + to_ = to (replace x) + walk z@(Z.Zip _ [] ) = z + walk z@(Z.Zip ls (r:rs)) = walk (Z.right next) + where + next = if context x `isPrefixOf` ls && r == from_ + then Z.replace to_ z + else z + +-- ---------------------------------------------------------------------- +-- train +-- ---------------------------------------------------------------------- + +learnConverge :: Int -- ^ floor + -> [Tag] -- ^ corpus + -> [Tag] -- ^ best guess + -> [Transform] +learnConverge floor cs bs = + if tscore r > floor + then r : learnConverge floor cs (tagOne r bs) + else [] + where + r = learnOne bs cs + +learnN :: Int + -> [Tag] -- ^ corpus + -> [Tag] -- ^ best guess + -> [Transform] +learnN = go [] + where + go acc 0 _ _ = acc + go acc n cs bs = + let r = learnOne bs cs + bs2 = tagOne r bs + in go (r:acc) (n - 1) cs bs2 + +-- | Not iteratively applying and relearning! Just doing one pass for now +learnOne :: [Tag] -- ^ corpus + -> [Tag] -- ^ best guess + -> Transform +learnOne best corpus = + bestTransform tags pairs + where + tags = Set.fromList best `Set.union` Set.fromList corpus + pairs = zipWith TagPair best corpus + +bestTransform :: Set Tag -> [TagPair] -> Transform +bestTransform tags xs = answer + where + answer = maximumBy (compare `on` tscore) (map best repls) + best r = bestInstance r dhist + repls = Set.toList (replacements tags) + dhist = deltaHistogram xs + +replacements :: Set Tag -> Set Replacement +replacements tags = + Set.fromList [ Replacement f t | f <- xs, t <- delete f xs ] + where + xs = Set.toList tags + +bestInstance :: Replacement -> DeltaHistogram -> Transform +bestInstance repl dhist = answer + -- we swap instead of just looking at the score so we can get consisent + -- ordering in case of a tie; not that it matters much just trying to + -- future-proof against changes in the Set implementation + where + answer = toTransform $ maximumBy (compare `on` swap) tmap + toTransform (t,i) = Transform [t] repl i + swap (x,y) = (y,x) + tmap = Map.toList $ Map.map (score repl) dhist + +type DeltaHistogram = Map Tag (Map TagPair Int) + +-- | how many times a replacement follows each context +deltaHistogram :: [TagPair] -> DeltaHistogram +deltaHistogram xs = + Map.map histogram $ + Map.fromListWith (++) $ zip prevs currs + where + prevs = map proposed xs + currs = map (\x -> [x]) $ drop 1 xs + +score :: Replacement -> Map TagPair Int -> Int +score r m = count good - count bad + where + count x = Map.findWithDefault 0 x m + good = TagPair (from r) (to r) + bad = TagPair (from r) (from r) + +plusPair :: Num a => (a,a) -> (a,a) -> (a,a) +plusPair (x1,x2) (y1,y2) = (x1 + y1, x2 + y2) diff --git a/NLP/Brillig/Unigram.hs b/NLP/Brillig/Unigram.hs new file mode 100644 --- /dev/null +++ b/NLP/Brillig/Unigram.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module NLP.Brillig.Unigram where + +import Data.List +import Data.Text (Text) +import qualified Data.Text as T +import Data.Function +import Data.Ord +import qualified Data.Map as Map + +import NLP.Brillig + +tag :: Count -> [Text] -> [Tagged Text] +tag m = map tagw + where + unknown = Tag "UNK" -- or mostfreq? + tagw w = (w, look w) + look w = case Map.lookup (T.toLower w) m of + Nothing -> unknown + Just sm -> best (Map.toList sm) + +best :: [(Tag,Int)] -> Tag +best = fst . maximumBy (compare `on` snd) + +mostfreq :: Count -> Tag +mostfreq = best . Map.toList . Map.unionsWith (+) . Map.elems diff --git a/NLP/Brillig/Util.hs b/NLP/Brillig/Util.hs new file mode 100644 --- /dev/null +++ b/NLP/Brillig/Util.hs @@ -0,0 +1,6 @@ +module NLP.Brillig.Util where + +import qualified Data.Map as Map + +histogram :: Ord a => [a] -> Map.Map a Int +histogram xs = Map.fromListWith (+) $ zip xs (repeat 1) diff --git a/NLP/Brillig/Wrong.hs b/NLP/Brillig/Wrong.hs new file mode 100644 --- /dev/null +++ b/NLP/Brillig/Wrong.hs @@ -0,0 +1,16 @@ +-- is this wrong? +module NLP.Brillig.Wrong where + +import Data.Binary +import qualified Data.Text.Encoding as T +import Data.Text ( Text ) + +import NLP.Brillig + +instance Binary Text where + put = put . T.encodeUtf8 + get = fmap T.decodeUtf8 get + +instance Binary Tag where + put = put . fromTag + get = fmap Tag get 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/brillig.cabal b/brillig.cabal new file mode 100644 --- /dev/null +++ b/brillig.cabal @@ -0,0 +1,76 @@ +-- brillig.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: brillig + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.3 + +-- A short (one-line) description of the package. +Synopsis: Simple part of speech tagger + +-- A longer description of the package. +Description: Right now, this just implements a stupid unigram tagger. + One day it may grow up to an HMM tagger or an implementation + of the Brill tagger. + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Eric Kow + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: eric.kow@gmail.com + +-- A copyright notice. +-- Copyright: + +Category: Natural language processing + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.8 + +Library + Exposed-modules: NLP.Brillig + , NLP.Brillig.Brill + , NLP.Brillig.Unigram + , NLP.Brillig.Wrong + , NLP.Brillig.Util + + -- Packages needed in order to build this package. + Build-depends: base < 5 + , binary + , containers + , directory + , filepath + , text + , ListZipper + +Executable brillig + -- .hs or .lhs file containing the Main module. + Main-is: brillig.hs + Hs-Source-Dirs: brillig + + -- Packages needed in order to build this package. + Build-depends: brillig + , base < 5 + , binary + , cmdargs == 0.7.* + , containers + , directory + , filepath + , text diff --git a/brillig/brillig.hs b/brillig/brillig.hs new file mode 100644 --- /dev/null +++ b/brillig/brillig.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE DeriveDataTypeable #-} + +import Control.Applicative +import Control.Arrow +import Control.Monad ( forM, when ) +import Data.Binary +import Data.Data +import Data.Ratio +import Data.Text (Text) +import Data.Version ( showVersion ) +import System.Console.CmdArgs +import System.Directory +import System.FilePath +import System.IO +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import Prelude hiding (floor) + +import qualified NLP.Brillig as Br +import NLP.Brillig hiding ( Tag ) +import NLP.Brillig.Brill +import NLP.Brillig.Unigram +import NLP.Brillig.Util +import NLP.Brillig.Wrong +import Paths_brillig +import Data.List + +data Tagger = Unigram { tdict :: FilePath } + | Brill { tdict :: FilePath, trules :: FilePath } + + +data Config = + Count { trainingD :: FilePath + , dict :: FilePath + } + | TrainBrill + { trainingD :: FilePath + , dict :: FilePath + , rules :: FilePath + , floor :: Int + } + | TagBrill + { dict :: FilePath + , input :: Maybe FilePath + , test :: Bool + , rules :: FilePath + } + | Tag { dict :: FilePath + , input :: Maybe FilePath + , test :: Bool + } + deriving (Show, Data, Typeable) + +configs = modes + [ Count { trainingD = def &= argPos 0 &= typ "DIR" + , dict = def &= argPos 1 &= typ "FILE" + } + , TrainBrill { trainingD = def &= argPos 0 &= typ "DIR" + , dict = def &= argPos 1 &= typ "FILE" + , rules = def &= argPos 2 &= typ "FILE" + , floor = 0 &= typ "INT" &= help "Stop at score..." + } &= help "training dict rules" + , Tag { dict = def &= argPos 0 &= typ "FILE" + , input = Nothing &= typ "FILE" &= help "Input file (stdin otherwise)" + , test = False &= help "Input is in word/tag format" + } + , TagBrill { dict = def &= argPos 0 &= typ "FILE" + , rules = def &= argPos 1 &= typ "FILE" + , input = Nothing &= typ "FILE" &= help "Input file (stdin otherwise)" + , test = False &= help "Input is in word/tag format" + } &= help "dict rules" + ] + &= summary ("brillig " ++ showVersion version) + +main = do + conf <- cmdArgs configs + case conf of + (Count _ _) -> counter conf + (TrainBrill _ _ _ _) -> brillTrainer conf + (Tag _ _ _) -> tagger conf + (TagBrill _ _ _ _) -> tagger conf + +-- ---------------------------------------------------------------------- +-- build dictionary +-- ---------------------------------------------------------------------- + +counter conf = do + let dir = trainingD conf + files <- getDirectoryContentsNoJunk dir + counts <- forM files $ \f -> do + hPutStrLn stderr $ "Reading " ++ f ++ "..." + process <$> T.readFile (dir f) + hPutStrLn stderr "Merging..." + encodeFile (dict conf) (mergeCounts counts) + +process :: Text -> Count +process = count . map readTag . T.words . T.toLower + +count :: [(Text, Br.Tag)] -> Count +count = Map.map histogram + . Map.fromListWith (++) + . map (second pure) + +mergeCounts :: [Count] -> Count +mergeCounts = Map.unionsWith (Map.unionWith (+)) + +-- ---------------------------------------------------------------------- +-- train Brill +-- ---------------------------------------------------------------------- + +brillTrainer conf = do + let dir = trainingD conf + c <- decodeFile (dict conf) + files <- getDirectoryContentsNoJunk dir + tags <- forM files $ \f -> do + hPutStrLn stderr $ "Reading " ++ f ++ "..." + map readTag . T.words . T.toLower <$> T.readFile (dir f) + let actual = concat tags + guessed = tag c (map fst actual) + rulez = learnConverge (floor conf) (map snd actual) (map snd guessed) + ruleStr = unlines (map show rulez) + hPutStrLn stderr ruleStr -- should trickle out due to lazy evaluation + writeFile (rules conf) ruleStr + +-- ---------------------------------------------------------------------- +-- do tagging +-- ---------------------------------------------------------------------- + +toTagger :: Config -> Tagger +toTagger TagBrill {..} = Brill dict rules +toTagger Tag {..} = Unigram dict +toTagger _ = error "Unknown tagger config!" + +tagger conf = do + c <- decodeFile (dict conf) + text <- case input conf of + Nothing -> T.getContents + Just inpF -> do + isD <- doesDirectoryExist inpF + if isD then do + fs <- getDirectoryContentsNoJunk inpF + T.concat <$> mapM (\f -> T.readFile (inpF f)) fs + else + T.readFile inpF + let sents = map T.words (T.lines text) + original = map (map readTag) sents + unitagged = map (tag c . map fst) original + tagged <- case toTagger conf of + Brill {..} -> do + rs <- (map read . lines) `fmap` readFile trules + return (map (brilltag rs) unitagged) + Unigram {..} -> return $ unitagged + T.putStrLn $ showTagging tagged + when (test conf) $ do + let correct = length [ w | ((w,t1),(w2,t2)) <- zip (concat original) (concat tagged), t1 == t2 ] + total = length (concat original) + putStrLn $ "Accuracy: " ++ show (fromRational (100 * fromIntegral correct % fromIntegral total)) + +showTagging = T.unlines . map (T.unwords . map showTag) + +-- ---------------------------------------------------------------------- +-- odds and ends +-- ---------------------------------------------------------------------- + +getDirectoryContentsNoJunk :: FilePath -> IO [FilePath] +getDirectoryContentsNoJunk dir = filter (not . (`elem` [".",".."])) <$> getDirectoryContents dir