packages feed

brillig (empty) → 0.3

raw patch · 9 files changed

+517/−0 lines, 9 filesdep +ListZipperdep +basedep +binarysetup-changed

Dependencies added: ListZipper, base, binary, brillig, cmdargs, containers, directory, filepath, text

Files

+ LICENSE view
@@ -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.
+ NLP/Brillig.hs view
@@ -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)
+ NLP/Brillig/Brill.hs view
@@ -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)
+ NLP/Brillig/Unigram.hs view
@@ -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
+ NLP/Brillig/Util.hs view
@@ -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)
+ NLP/Brillig/Wrong.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ brillig.cabal view
@@ -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
+ brillig/brillig.hs view
@@ -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