toktok (empty) → 0.5

raw patch · 14 files changed

+458/−0 lines, 14 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bytestring, containers, criterion, filepath, gf, haskell98, iconv, progression

Files

• Benchmark.hs +69/−0
• LICENSE +0/−0
• Main.hs +68/−0
• Setup.hs +2/−0
• Toktok.hs +8/−0
• Toktok/Lattice.hs +10/−0
• Toktok/Lexer.hs +14/−0
• Toktok/Sandhi.hs +7/−0
• Toktok/Stack.hs +36/−0
• Toktok/Transducer.hs +87/−0
• Toktok/Trie.hs +45/−0
• tests/Main.hs +13/−0
• toktok.cabal +69/−0
• tools/ExtractLexicon.hs +30/−0

@@ -0,0 +1,69 @@+module Main where++import Control.Monad (when)+import Criterion.Config+import Criterion.Main+import Data.Monoid (Last(..))+import Data.Map (Map)+import qualified Data.Map as Map+import System (getArgs, getProgName)+import System.FilePath ((</>))+import System.IO (stderr, hPutStrLn)+import Toktok (Lexer, mkLexer, mkLexerWithSandhis)++myConfig = defaultConfig {+             cfgSummaryFile = Last $ Just "benchmark.csv"}++main = defaultMainWith myConfig (return ()) $+         map createBGroup [ ("Transducer", mkLexerWithSandhis [])+                          , ("Tries", mkLexer)+                          , ("Baseline", baseline)+                          , ("Dummy", dummy)+                          ]++createBGroup :: (String, [String] -> Lexer) -> Benchmark+createBGroup (name, mkLexer)+   = bgroup name+            [ bench "English" $ nfIO $ mkBenchmark "english" mkLexer+            , bench "French"  $ nfIO $ mkBenchmark "french"  mkLexer+            ]++mkBenchmark :: String -> ([String] -> Lexer) -> IO ()+mkBenchmark dir mklexerf = do+                       lexicon <- readLexicon dir+                       let lexer = mkLexer (" ":filter (not . null) lexicon)+                       sts <- readSentences dir+                       let results = map (not . null . lexer) sts+                       --putStrLn $ unlines $ map show results+                       when (not $ and results) $ error "Problem..."+                       return ()+                       +readLexicon :: String -> IO [String]+readLexicon dir = readLineFiles $ "data" </> dir </> "lexicon.txt"++readSentences :: String -> IO [String]+readSentences dir = readLineFiles $ "data" </> dir </> "sentences.txt"++readLineFiles :: FilePath -> IO [String]+readLineFiles f = do+                  t <- readFile f+                  return $ lines t++-- Lexers for comparaison++-- | This is the standard haskell lexer, 'words'.+-- It just split the string where there is white-spaces.+dummy :: [String] -> Lexer+dummy _ = return . words++-- | this is a lexer based on haskell maps+baseline :: [String] -> Lexer+baseline ss = useMapLexer mapLexer+   where mapLexer = Map.fromList $ map (\x -> (x,True)) ss+         useMapLexer :: Map String Bool -> Lexer+         useMapLexer m = uml 1+            where uml i s | i >= length s = []+                  uml i s = case Map.lookup (take i s) m of+                         Just True -> [take i s:l | l <- uml 1 (drop i s)]+                                      ++ uml (i + 1) s+                         _         -> uml (i + 1) s

@@ -0,0 +1,68 @@+module Main where++import System+import System.Console.GetOpt++-- Default script options +defaultOptions :: Options+defaultOptions = Options {+     runScript = runLexer+   , lexerPath = "lexer.lex"+   , txtFiles  = []+}++-- Main function : does argument parsing+main = do+      args <- getArgs+      let (optHelpers, nonOpt, msg) = getOpt Permute options args+      let scriptOptions = compose optHelpers defaultOptions+      -- this next line is not perfect, but I'm not shure I can do better...+      runScript scriptOptions scriptOptions++-- Main script : use a lexer on stdin+runLexer :: Options -> IO ()+runLexer opt = do+                 let files = txtFiles opt+                 wds <- if not $ null $ txtFiles opt+                         then do cs <- mapM readFile $ txtFiles opt+                                 return $ concatMap lines cs+                         else getContents >>= return . lines+                 return ()++mkLexer :: Options -> IO ()+mkLexer opt = undefined++-- Options declaration+options :: [OptDescr (Options -> Options)]+options = [ +     Option ['V'] ["version"] (NoArg showVersion)           +                  "show version number"+   , Option []    ["mklexer"] (NoArg setMkLexer) +                  "build a lexer from a lexicon"+   ]++-- Option parsing machinery++-- Options type+-- the main function is in the options so we can switch it according to the option given (ex: the --version option)+data Options = Options {+     runScript :: Options -> IO ()+   , lexerPath :: String+   , txtFiles  :: [String]+   }++-- Options helpers+showVersion :: Options -> Options+showVersion o = o { runScript = \_ -> do+     putStrLn $ "gfdoc : GF documentation tool version " ++ "???"--_VERSION+     exitWith ExitSuccess+   }++setMkLexer :: Options -> Options+setMkLexer o = o { runScript = mkLexer }++-- Utilities+-- this compose a list of function together+compose :: [a -> a] -> a -> a+compose fs v = foldl (flip (.)) id fs $ v+

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,8 @@+module Toktok +   ( Lexer+   , mkLexer+   , mkLexerWithSandhis+   ) where+++import Toktok.Lexer (Lexer, mkLexer, mkLexerWithSandhis)

@@ -0,0 +1,10 @@+module Toktok.Lattice where++import Control.Monad (liftM)++type Lattice a = [[a]]++-- lattice building+--- constructor+(<:) :: a -> Lattice a  -> Lattice a+s <: l = liftM (s:) l

@@ -0,0 +1,14 @@+module Toktok.Lexer where++import Toktok.Trie+import Toktok.Transducer+import Toktok.Sandhi++type Lexer = String -> [[String]]++mkLexer :: [String] -> Lexer+mkLexer = apply . fromList++mkLexerWithSandhis :: [Sandhi] -> [String] -> Lexer+mkLexerWithSandhis sandhis strings +   = applyTransducer $ flip mkTransducer sandhis $ mkTrie strings

@@ -0,0 +1,7 @@+module Toktok.Sandhi where+++data Sandhi = Sandhi String String String++mkSandhi :: String -> String -> String -> Sandhi+mkSandhi u v w = Sandhi (reverse u) v w

@@ -0,0 +1,36 @@+{-# LANGUAGE TypeSynonymInstances #-}+module Toktok.Stack where++import Data.Monoid++newtype Stack a = Stack [[a]]+   deriving (Show, Eq)++merge :: Stack a -> Stack a -> Stack a+merge (Stack a) (Stack b) = Stack $ merge' a b+   where merge' [] b = b+         merge' a [] = a+         merge' (l:ls) (l':ls') +            = (l ++ l'):merge' ls ls'++singleton :: Int -> a -> Stack a+singleton n a = Stack $ singleton' n a+   where singleton' n x | n <= 0 = error "index should be > 0"+         singleton' n x | n == 1 =  [[x]]+         singleton' n x = []:singleton' (n-1) x++instance Monoid (Stack a) where+   mempty = Stack []+   mappend = merge+++head :: Stack a -> [a]+head (Stack []) = []+head (Stack (l:_)) = l++pop:: Stack a -> Stack a+pop (Stack []) = Stack []+pop (Stack (_:ls)) = Stack ls++emptyStack :: Stack a+emptyStack = Stack []

@@ -0,0 +1,87 @@+-- | This is the module defining the transducer.+-- a transducer is build from a Trie with added sandhis.+module Toktok.Transducer where++import Data.Map (Map)+import Data.Monoid+import qualified Data.Map as Map+import Data.List(isPrefixOf)+import Data.Char(isUpper, toLower)++import Toktok.Lattice ((<:), Lattice)+import Toktok.Sandhi +import Toktok.Stack+import Toktok.Trie+import qualified Toktok.Stack as Stack++data Transducer +   = Trans Bool                  --  Acceptance+           (Map Char Transducer) -- Deterministic part+           [Sandhi]              -- Non deterministic part++-- | Build a transducer from a trie and a list of sandhis...+mkTransducer :: Trie -> [Sandhi] -> Transducer+mkTransducer t sandhis = case mkTransducer' t sandhis "" of+                           (t,Stack []) -> t+                           _      -> error "Non empty stack"++mkTransducer' :: Trie -> [Sandhi] -> String -> (Transducer, Stack Sandhi)+mkTransducer' (Trie b trieMap) sandhis pref+   = (Trans b newMap (Stack.head oldStack), newStack)+   where intermediateMap +            = Map.mapWithKey (\ k t -> mkTransducer' t sandhis (k:pref)) trieMap+         newMap = fmap fst intermediateMap+         oldStack = mconcat $ map snd $ Map.elems intermediateMap+         newStack = merge (Stack.pop oldStack) createStack+         -- Sandhi are applied only if we are at the end of a word+         goodSandhis = if b +                        then filter (\(Sandhi u _ _) -> u `isPrefixOf` pref) sandhis+                        else []+         sandhiToStack s@(Sandhi u _ _) = Stack.singleton (length u) s+         createStack = mconcat $ map sandhiToStack goodSandhis++-- | In this algorithm, we segment the input in the folowing way+-- input = ¬pref ++ suf +-- or input = ¬pref ++ c ++ suf+-- where pref is the already processed part.+applyTransducer :: Transducer -> String -> Lattice String+applyTransducer rootT = apply' rootT []+   where -- first, if we have consumed all the input+         apply' (Trans True  _ _) pref [] = [[reverse pref]]+         apply' (Trans False _ _) pref [] = []+         -- then, if the state is final+         apply' (Trans True  trie sandhis) pref suf+            = (reverse pref <: apply' rootT "" suf)+           ++ continueWithTrie    trie    pref suf+           ++ continueWithSandhis sandhis pref suf+         -- then if the state is not final...+         apply' (Trans False trie sandhis) pref suf+            = continueWithTrie    trie    pref suf+           ++ continueWithSandhis sandhis pref suf+         -- continue processing using (deterministic) trie+         continueWithTrie trieMap pref (c:suf)+            =  case Map.lookup c trieMap of+                    Nothing -> []+                    Just t' -> apply' t' (c:pref) suf+           ++ if isUpper c+               then case Map.lookup (toLower c) trieMap of+                         Nothing -> []+                         Just t' -> apply' t' (toLower c:pref) suf+               else []+         -- continue processing using sandhis+         continueWithSandhis [] _ _ = []      -- processed all sandhis+         continueWithSandhis sandhis pref suf+            = concatMap (\ s -> applySandhi s pref suf) sandhis+         applySandhi (Sandhi u v w) pref suf | w `isPrefixOf` suf+            = (reverse $ u ++ pref) <: (apply' (access v rootT) (reverse v) suf')+            where suf' = drop (length w) suf+++-- | Access a state in a transducter, ignoring sandhis and intermediate+-- final states.+access :: String -> Transducer -> Transducer+access [] t = t+access (c:cs) (Trans _ map _) +   = case Map.lookup c map of+      Nothing -> undefined+      Just t' -> access cs t'

@@ -0,0 +1,45 @@+module Toktok.Trie where++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Char (toLower, toUpper, isUpper)++data Trie = Trie Bool (Map Char Trie)++emptyTrie = Trie False Map.empty ++mkTrie = fromList++fromList :: [String] -> Trie+fromList [] = emptyTrie+fromList (w:ws) = addWord w $ fromList ws++addWord :: String -> Trie -> Trie+addWord []     (Trie _ m) +   = Trie True m+addWord (c:cs) (Trie b m) | Map.member c m+   = Trie b $ Map.update (return . addWord cs) c m+addWord (c:cs) (Trie b m) +   = Trie b $ Map.insert c (addWord cs emptyTrie) m++apply :: Trie -> String -> [[String]]+apply trie = apply' trie []+   where apply' (Trie True _) w [] = [[reverse w]]+         apply' (Trie False _) w [] = []+         apply' (Trie True m) w (c:cs) = (apply' trie "" (c:cs) +                                          >>= return . (reverse w:))+                                      ++ apply'' m c cs w+         apply' (Trie False m) w (c:cs) = apply'' m c cs w+         apply'' m c cs w = case Map.lookup c m of+                             Nothing -> []+                             Just n -> apply' n (c:w) cs+                         ++ if isUpper c+                             then case Map.lookup (toLower c) m of+                                       Nothing -> []+                                       Just n -> apply' n (toLower c:w) cs+                             else []+         ++test :: [[String]]+test = apply t "aabbbc"+  where t = fromList ["a", "ab", "bb", "c", "b"]

@@ -0,0 +1,13 @@+module Main where++import Toktok.Test.Transducer (transducersTests)+import Toktok.Test.Stack++import Test.HUnit+import Test.QuickCheck++main = do+       runTestTT tests+       runTestTT stackTests++tests = transducersTests

@@ -0,0 +1,69 @@+Name:                toktok+Version:             0.5+Description:         An ambiguous tokenizer for GF+Category:            Natural Language Processing+License:             GPL+License-file:        LICENSE+Author:              Grégoire Détrez <gdetrez@crans.org>+Maintainer:          Grégoire Détrez <gdetrez@crans.org>+Build-Type:          Simple+Cabal-Version:       >=1.2++flag benchmark+  Description: Build the benchmarking binary+  Default:     False++flag test+  Description: Build the tests+  Default:     False++Executable toktok-benchmark+  Main-is: Benchmark.hs+  if !flag(benchmark)+    buildable: False+  Build-Depends:+    criterion,+    progression,+    filepath+  ghc-options: -O2++Executable toktok-test+  Main-is: tests/Main.hs+  Hs-source-dirs: ., tests+  if !flag(test)+    buildable: False+  Build-Depends:+    QuickCheck >= 2,+    HUnit+  ghc-options: -O2++Executable toktok+  Main-is:           Main.hs+  Build-Depends:     +    base >= 4.1 && < 5,+    bytestring,+    gf,+    iconv+  ghc-options: -O2++Executable gf-extract-lexicon+  Main-is:           ExtractLexicon.hs+  Hs-Source-Dirs:    tools+  Build-Depends:     base >= 4.1 && < 5+  ghc-options: -O2++library+  build-depends: +    base >= 4.1 && < 5,+    containers,+    haskell98+  exposed-modules: +    Toktok+  other-modules:+    Toktok.Lattice+    Toktok.Lexer+    Toktok.Sandhi+    Toktok.Stack+    Toktok.Transducer+    Toktok.Trie+  ghc-options: -O2

@@ -0,0 +1,30 @@+module Main where++import System (getArgs, getProgName)+import IO+import PGF (readPGF, readLanguage, getLexicon)+import Data.ByteString.Lazy.Char8 (pack, unpack)+import Codec.Text.IConv (convert)+--import System.Console.GetOpt++-- this is the main module to extract lexicon from a GF grammar.+-- the arguments are : grammar file, concrete syntax name.++main :: IO ()+main = do+       args <- getArgs+       case args of +        [gram, lang] -> do+                        g <- readPGF gram+                        let Just l = readLanguage lang+                        putStrLn $ unlines $ map toUTF8 $ getLexicon g l+                        +        _ -> usage++usage :: IO ()+usage = do+        name <- getProgName+        hPutStrLn stderr $ "usage: " ++ name ++ " grammar.pgf LangName"++toUTF8 :: String -> String+toUTF8 = unpack . convert "LATIN1" "UTF-8" . pack