diff options
| -rw-r--r-- | src/GF/API.hs | 13 | ||||
| -rw-r--r-- | src/GF/Shell.hs | 2 | ||||
| -rw-r--r-- | src/GF/Speech/CFGToFiniteState.hs | 15 | ||||
| -rw-r--r-- | src/GF/Speech/PrFA.hs | 11 | ||||
| -rw-r--r-- | src/GF/Speech/PrSLF.hs | 31 | ||||
| -rw-r--r-- | src/GF/System/ATKSpeechInput.hs | 77 | ||||
| -rw-r--r-- | src/GF/System/NoSpeechInput.hs | 9 | ||||
| -rw-r--r-- | src/GF/UseGrammar/Custom.hs | 22 |
8 files changed, 99 insertions, 81 deletions
diff --git a/src/GF/API.hs b/src/GF/API.hs index 469b762ed..906bd062f 100644 --- a/src/GF/API.hs +++ b/src/GF/API.hs @@ -75,6 +75,7 @@ import GF.Infra.UseIO import GF.Data.Zipper import Data.List (nub) +import Data.Maybe (fromMaybe) import Control.Monad (liftM) import System (system) @@ -208,13 +209,15 @@ speechGenerate opts str = do --- system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan) return () --- FIXME: look at flags -speechInput :: Options -> StateGrammar -> IO String -speechInput opt s = recognizeSpeech name opts cfg +speechInput :: Options -> StateGrammar -> IO [String] +speechInput opt s = recognizeSpeech name language cfg cat number where - opts = stateOptions s + opts = addOptions opt (stateOptions s) name = cncId s - cfg = stateCFG s + cfg = stateCFG s -- FIXME: use lang flag to select grammar + language = fromMaybe "en_UK" (getOptVal opts speechLanguage) + cat = fromMaybe "S" (getOptVal opts gStartCat) + number = optIntOrN opts flagNumber 1 optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String optLinearizeTreeVal opts gr = err id id . optLinearizeTree opts gr diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs index eb13cbdf7..417f01215 100644 --- a/src/GF/Shell.hs +++ b/src/GF/Shell.hs @@ -348,7 +348,7 @@ execC co@(comm, opts0) sa@(sh@(st,(h,_,_,_)),a) = checkOptions st co >> case com CWriteFile file -> justOutputArg opts (writeFile file) sa CAppendFile file -> justOutputArg opts (appendFile file) sa CSpeakAloud -> justOutputArg opts (speechGenerate opts) sa - CSpeechInput -> returnArgIO (speechInput opts gro >>= return . AString) sa + CSpeechInput -> returnArgIO (speechInput opts gro >>= return . AString . unlines) sa CSystemCommand s -> case a of AUnit -> justOutput opts (system s >> return ()) sa _ -> systemArg opts a s sa diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs index b0d02983a..2fe3dabb1 100644 --- a/src/GF/Speech/CFGToFiniteState.hs +++ b/src/GF/Speech/CFGToFiniteState.hs @@ -27,7 +27,6 @@ import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, NameProfile(..)) import GF.Conversion.Types import GF.Infra.Ident (Ident) -import GF.Infra.Option (Options) import GF.Speech.FiniteState import GF.Speech.Graph @@ -57,9 +56,8 @@ data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))] -cfgToFA :: Options -> CGrammar -> DFA String -cfgToFA opts = minimize . compileAutomaton start . makeSimpleRegular - where start = getStartCat opts +cfgToFA :: String -> CGrammar -> DFA String +cfgToFA start = minimize . compileAutomaton start . makeSimpleRegular makeSimpleRegular :: CGrammar -> CFRules makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgToCFRules @@ -155,13 +153,12 @@ make_fa c@(g,ns) q0 alpha q1 fa = -- * Compile a strongly regular grammar to a DFA with sub-automata -- -cfgToMFA :: Options -> CGrammar -> MFA String -cfgToMFA opts g = buildMFA start g - where start = getStartCat opts +cfgToMFA :: String -> CGrammar -> MFA String +cfgToMFA start g = buildMFA start g -- | Build a DFA by building and expanding an MFA -cfgToFA' :: Options -> CGrammar -> DFA String -cfgToFA' opts g = mfaToDFA $ cfgToMFA opts g +cfgToFA' :: String -> CGrammar -> DFA String +cfgToFA' start g = mfaToDFA $ cfgToMFA start g buildMFA :: Cat_ -- ^ Start category -> CGrammar -> MFA String diff --git a/src/GF/Speech/PrFA.hs b/src/GF/Speech/PrFA.hs index e3c22ef1d..c5ac4e134 100644 --- a/src/GF/Speech/PrFA.hs +++ b/src/GF/Speech/PrFA.hs @@ -23,7 +23,6 @@ import GF.Conversion.Types import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..),symbol) import GF.Infra.Ident -import GF.Infra.Option import GF.Infra.Print import GF.Speech.CFGToFiniteState import GF.Speech.FiniteState @@ -37,10 +36,10 @@ import Data.Maybe (fromMaybe) faGraphvizPrinter :: Ident -- ^ Grammar name - -> Options -> CGrammar -> String -faGraphvizPrinter name opts cfg = + -> String -> CGrammar -> String +faGraphvizPrinter name start cfg = prFAGraphviz $ mapStates (const "") fa - where fa = cfgToFA opts cfg + where fa = cfgToFA start cfg -- | Convert the grammar to a regular grammar and print it in BNF @@ -53,8 +52,8 @@ regularPrinter = prCFRules . makeSimpleRegular showRhs = unwords . map (symbol id show) faCPrinter :: Ident -- ^ Grammar name - -> Options -> CGrammar -> String -faCPrinter name opts cfg = fa2c $ cfgToFA opts cfg + -> String -> CGrammar -> String +faCPrinter name start cfg = fa2c $ cfgToFA start cfg fa2c :: DFA String -> String fa2c fa = undefined
\ No newline at end of file diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs index ba7dea3c8..fbba89692 100644 --- a/src/GF/Speech/PrSLF.hs +++ b/src/GF/Speech/PrSLF.hs @@ -26,7 +26,6 @@ import GF.Conversion.Types import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..),symbol) import GF.Infra.Ident -import GF.Infra.Option import GF.Infra.Print import GF.Speech.CFGToFiniteState import GF.Speech.FiniteState @@ -54,9 +53,9 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int } type SLF_FA = FA State (Maybe (MFALabel String)) () -mkFAs :: Options -> CGrammar -> (SLF_FA, [(String,SLF_FA)]) -mkFAs opts cfg = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs]) - where MFA main subs = {- renameSubs $ -} cfgToMFA opts cfg +mkFAs :: String -> CGrammar -> (SLF_FA, [(String,SLF_FA)]) +mkFAs start cfg = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs]) + where MFA main subs = {- renameSubs $ -} cfgToMFA start cfg slfStyleFA :: Eq a => DFA a -> FA State (Maybe a) () slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing () @@ -76,9 +75,9 @@ renameSubs (MFA main subs) = MFA (renameLabels main) subs' -- * SLF graphviz printing (without sub-networks) -- -slfGraphvizPrinter :: Ident -> Options -> CGrammar -> String -slfGraphvizPrinter name opts cfg - = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' opts cfg +slfGraphvizPrinter :: Ident -> String -> CGrammar -> String +slfGraphvizPrinter name start cfg + = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' start cfg where gvFA = mapStates (fromMaybe "") . mapTransitions (const "") @@ -87,9 +86,9 @@ slfGraphvizPrinter name opts cfg -- slfSubGraphvizPrinter :: Ident -- ^ Grammar name - -> Options -> CGrammar -> String -slfSubGraphvizPrinter name opts cfg = Dot.prGraphviz g - where (main, subs) = mkFAs opts cfg + -> String -> CGrammar -> String +slfSubGraphvizPrinter name start cfg = Dot.prGraphviz g + where (main, subs) = mkFAs start cfg g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs m = gvSLFFA Nothing main @@ -114,9 +113,9 @@ gvSLFFA n fa = -- * SLF printing (without sub-networks) -- -slfPrinter :: Ident -> Options -> CGrammar -> String -slfPrinter name opts cfg - = prSLF (automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' opts cfg) "" +slfPrinter :: Ident -> String -> CGrammar -> String +slfPrinter name start cfg + = prSLF (automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' start cfg) "" -- -- * SLF printing (with sub-networks) @@ -124,10 +123,10 @@ slfPrinter name opts cfg -- | Make a network with subnetworks in SLF slfSubPrinter :: Ident -- ^ Grammar name - -> Options -> CGrammar -> String -slfSubPrinter name opts cfg = prSLFs slfs "" + -> String -> CGrammar -> String +slfSubPrinter name start cfg = prSLFs slfs "" where - (main,subs) = mkFAs opts cfg + (main,subs) = mkFAs start cfg slfs = SLFs [(c, faToSLF fa) | (c,fa) <- subs] (faToSLF main) faToSLF = automatonToSLF mfaNodeToSLFNode diff --git a/src/GF/System/ATKSpeechInput.hs b/src/GF/System/ATKSpeechInput.hs index 4f8fe1dce..2b46915f5 100644 --- a/src/GF/System/ATKSpeechInput.hs +++ b/src/GF/System/ATKSpeechInput.hs @@ -59,64 +59,71 @@ getLanguage l = ("HPARM:CMNDEFAULT", res ++ "/UK_SI_ZMFCC/cepmean")] } "sv_SE" -> do - let res = "/home/bjorn/projects/atkswe/stoneage-swe" + let res = "/home/bjorn/projects/atkswe/numerals-swe/final" return $ ATKLang { - hmmlist = res ++ "/triphones1", - mmf0 = res ++ "/hmm12/macros", - mmf1 = res ++ "/hmm12/hmmdefs", - dict = res ++ "/dict", + hmmlist = res ++ "/hmm_tri/hmmlist", + mmf0 = res ++ "/hmm_tri/macros", + mmf1 = res ++ "/hmm_tri/hmmdefs", + dict = res ++ "/NumeralsSwe.dct", opts = [("TARGETKIND", "MFCC_0_D_A")] } _ -> fail $ "ATKSpeechInput: language " ++ l ++ " not supported" --- | List of the languages for which we have already loaded the HMM +-- | Current language for which we have loaded the HMM -- and dictionary. -{-# NOINLINE languages #-} -languages :: IORef [String] -languages = unsafePerformIO $ newIORef [] +{-# NOINLINE currentLang #-} +currentLang :: IORef (Maybe String) +currentLang = unsafePerformIO $ newIORef Nothing + +-- | Initializes the ATK, loading the given language. +-- ATK must not be initialized when calling this function. +loadLang :: String -> IO () +loadLang lang = + do + l <- getLanguage lang + config <- getEnv_ "GF_ATK_CFG" gf_atk_cfg_error + hPutStrLn stderr $ "Initializing ATK..." + initialize (Just config) (opts l) + let hmmName = "hmm_" ++ lang + dictName = "dict_" ++ lang + hPutStrLn stderr $ "Initializing ATK (" ++ lang ++ ")..." + loadHMMSet hmmName (hmmlist l) (mmf0 l) (mmf1 l) + loadDict dictName (dict l) + writeIORef currentLang (Just lang) initATK :: String -> IO () -initATK language = +initATK lang = do - l <- getLanguage language - ls <- readIORef languages - when (null ls) $ do - config <- getEnv_ "GF_ATK_CFG" gf_atk_cfg_error - hPutStrLn stderr $ "Initializing ATK..." - -- FIXME: different recognizers need different global options - initialize (Just config) (opts l) - when (language `notElem` ls) $ - do - let hmmName = "hmm_" ++ language - dictName = "dict_" ++ language - hPutStrLn stderr $ "Initializing ATK (" ++ language ++ ")..." - loadHMMSet hmmName (hmmlist l) (mmf0 l) (mmf1 l) - loadDict dictName (dict l) - writeIORef languages (language:ls) + ml <- readIORef currentLang + case ml of + Nothing -> loadLang lang + Just l | l == lang -> return () + | otherwise -> do + deinitialize + loadLang lang recognizeSpeech :: Ident -- ^ Grammar name - -> Options -> CGrammar -> IO String -recognizeSpeech name opts cfg = + -> String -- ^ Language, e.g. en_UK + -> CGrammar -- ^ Context-free grammar for input + -> String -- ^ Start category name + -> Int -- ^ Number of utterances + -> IO [String] +recognizeSpeech name language cfg start number = do - -- Options - let language = fromMaybe "en_UK" (getOptVal opts speechLanguage) - cat = fromMaybe "S" (getOptVal opts gStartCat) ++ "{}.s" - number = optIntOrN opts flagNumber 1 - -- FIXME: use values of cat and number flags - let slf = slfPrinter name opts cfg + -- FIXME: use cat + let slf = slfPrinter name start cfg n = prIdent name hmmName = "hmm_" ++ language dictName = "dict_" ++ language slfName = "gram_" ++ n recName = "rec_" ++ language ++ "_" ++ n - print opts writeFile "debug.net" slf initATK language hPutStrLn stderr "Loading grammar..." loadGrammarString slfName slf createRecognizer recName hmmName dictName slfName hPutStrLn stderr "Listening..." - s <- recognize recName + s <- replicateM number (recognize recName) return s diff --git a/src/GF/System/NoSpeechInput.hs b/src/GF/System/NoSpeechInput.hs index ca78bc3ee..04197ce92 100644 --- a/src/GF/System/NoSpeechInput.hs +++ b/src/GF/System/NoSpeechInput.hs @@ -18,6 +18,11 @@ import GF.Infra.Ident (Ident) import GF.Infra.Option (Options) import GF.Conversion.Types (CGrammar) + recognizeSpeech :: Ident -- ^ Grammar name - -> Options -> CGrammar -> IO String -recognizeSpeech _ _ _ = fail "No speech input available" + -> String -- ^ Language, e.g. en_UK + -> CGrammar -- ^ Context-free grammar for input + -> String -- ^ Start category name + -> Int -- ^ Number of utterances + -> IO [String] +recognizeSpeech _ _ _ _ _ = fail "No speech input available" diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index b65c6d815..9a6cd0e21 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -101,6 +101,7 @@ import GF.Infra.UseIO import Control.Monad import Data.Char +import Data.Maybe (fromMaybe) -- character codings import GF.Text.Unicode @@ -254,23 +255,29 @@ customGrammarPrinter = probs = stateProbs s in srgsXmlPrinter name opts (Just probs) $ stateCFG s) ,(strCI "slf", \s -> let opts = stateOptions s + start = getStartCat opts name = cncId s - in slfPrinter name opts $ stateCFG s) + in slfPrinter name start $ stateCFG s) ,(strCI "slf_graphviz", \s -> let opts = stateOptions s + start = getStartCat opts name = cncId s - in slfGraphvizPrinter name opts $ stateCFG s) + in slfGraphvizPrinter name start $ stateCFG s) ,(strCI "slf_sub", \s -> let opts = stateOptions s + start = getStartCat opts name = cncId s - in slfSubPrinter name opts $ stateCFG s) + in slfSubPrinter name start $ stateCFG s) ,(strCI "slf_sub_graphviz", \s -> let opts = stateOptions s + start = getStartCat opts name = cncId s - in slfSubGraphvizPrinter name opts $ stateCFG s) + in slfSubGraphvizPrinter name start $ stateCFG s) ,(strCI "fa_graphviz", \s -> let opts = stateOptions s + start = getStartCat opts name = cncId s - in faGraphvizPrinter name opts $ stateCFG s) + in faGraphvizPrinter name start $ stateCFG s) ,(strCI "fa_c", \s -> let opts = stateOptions s + start = getStartCat opts name = cncId s - in faCPrinter name opts $ stateCFG s) + in faCPrinter name start $ stateCFG s) ,(strCI "regular", regularPrinter . stateCFG) ,(strCI "plbnf", prLBNF True) ,(strCI "lbnf", prLBNF False) @@ -321,7 +328,8 @@ customGrammarPrinter = -- ,(strCI "cfg-old", PrtOld.prt . CnvOld.cfg . statePInfoOld) ] where stateGrammarLangOpts s = (stateOptions s, stateGrammarLang s) - + getStartCat :: Options -> String + getStartCat opts = fromMaybe "S" (getOptVal opts gStartCat) ++ "{}.s" customMultiGrammarPrinter = customData "Printers for multiple grammars, selected by option -printer=x" $ |