diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Speech/PrSLF.hs | 30 | ||||
| -rw-r--r-- | src/GF/Speech/TransformCFG.hs | 63 |
2 files changed, 63 insertions, 30 deletions
diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs index 044a94ed0..cec2b89fd 100644 --- a/src/GF/Speech/PrSLF.hs +++ b/src/GF/Speech/PrSLF.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/06/17 12:46:05 $ +-- > CVS $Date: 2005/09/02 15:47:46 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- This module converts a CFG to an SLF finite-state network -- for use with the ATK recognizer. The SLF format is described @@ -32,38 +32,36 @@ import GF.Infra.Option import Data.Char (toUpper,toLower) -data SLF = SLF [SLFNode] [SLFEdge] +data SLF = SLF { slfNodes :: [SLFNode], slfEdges :: [SLFEdge] } -data SLFNode = SLFNode Int SLFWord +data SLFNode = SLFNode { nId :: Int, nWord :: SLFWord } -type SLFWord = Maybe String +-- | An SLF word is a word, or the empty string. +type SLFWord = String -data SLFEdge = SLFEdge Int Int Int +data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int } slfPrinter :: Ident -- ^ Grammar name -> Options -> CGrammar -> String slfPrinter name opts cfg = prSLF slf "" - where gr = makeNice cfg - gr' = makeRegular gr - srg = makeSRG name opts gr' - slf = srg2slf srg + where slf = srg2slf $ makeSRG name opts $ makeRegular $ makeNice cfg srg2slf :: SRG -> SLF -srg2slf = undefined +srg2slf = undefined -- should use TransformCFG.compileAutomaton prSLF :: SLF -> ShowS -prSLF (SLF ns es) = header . unlinesS (map prNode ns) . unlinesS (map prEdge es) +prSLF (SLF { slfNodes = ns, slfEdges = es}) = header . unlinesS (map prNode ns) . unlinesS (map prEdge es) where header = showString "VERSION=1.0" . nl . prFields [("N",show (length ns)),("L", show (length es))] . nl - prNode (SLFNode i w) = prFields [("I",show i),("W",showWord w)] - prEdge (SLFEdge i s e) = prFields [("J",show i),("S",show s),("E",show e)] + prNode n = prFields [("I",show (nId n)),("W",showWord (nWord n))] + prEdge e = prFields [("J",show (eId e)),("S",show (eStart e)),("E",show (eEnd e))] showWord :: SLFWord -> String -showWord Nothing = "!NULL" -showWord (Just w) = w -- FIXME: convert words to upper case +showWord "" = "!NULL" +showWord w = w -- FIXME: convert words to upper case prFields :: [(String,String)] -> ShowS prFields fs = unwordsS [ showString l . showChar '=' . showString v | (l,v) <- fs ] diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs index db9b009a6..df2a787f4 100644 --- a/src/GF/Speech/TransformCFG.hs +++ b/src/GF/Speech/TransformCFG.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/06/17 12:46:05 $ +-- > CVS $Date: 2005/09/02 15:47:47 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.13 $ +-- > CVS $Revision: 1.14 $ -- -- This module does some useful transformations on CFGs. -- @@ -40,7 +40,7 @@ type CFRules = FiniteMap Cat_ [CFRule_] -- | Remove left-recursion and categories with no productions -- from a context-free grammar. makeNice :: CGrammar -> [CFRule_] -makeNice = concat . eltsFM . makeNice' . groupProds . cfgToCFRules +makeNice = ungroupProds . makeNice' . groupProds . cfgToCFRules where makeNice' = removeLeftRecursion . removeEmptyCats cfgToCFRules :: CGrammar -> [CFRule_] @@ -55,6 +55,9 @@ groupProds :: [CFRule_] -> CFRules groupProds = addListToFM_C (++) emptyFM . map (\rs -> (ruleCat rs,[rs])) where ruleCat (CFRule c _ _) = c +ungroupProds :: CFRules -> [CFRule_] +ungroupProds = concat . eltsFM + -- | Remove productions which use categories which have no productions removeEmptyCats :: CFRules -> CFRules removeEmptyCats rss = listToFM $ fix removeEmptyCats' $ fmToList rss @@ -67,9 +70,6 @@ removeEmptyCats rss = listToFM $ fix removeEmptyCats' $ fmToList rss emptyCats = filter (nothingOrNull . flip lookup rs) allCats k' = map (\ (c,xs) -> (c, filter (not . anyUsedBy emptyCats) xs)) keep -anyUsedBy :: [Cat_] -> CFRule_ -> Bool -anyUsedBy ss (CFRule _ r _) = or [c `elem` ss | Cat c <- r] - removeLeftRecursion :: CFRules -> CFRules removeLeftRecursion rs = listToFM $ concatMap removeDirectLeftRecursion $ map handleProds $ fmToList rs where @@ -104,19 +104,50 @@ makeRegular :: [CFRule_] -> [CFRule_] makeRegular = undefined {- -isRightLinear :: [Cat_] -- ^ The categories to consider - -> CFRule_ - -> Bool -isRightLinear _ (CFRule _ ss _) | all isTerminal ss = True -isRightLinear cs +-- | Get the sets of mutually recursive non-terminals for a grammar. +mutRecCats :: Eq c => [CFRule c n t] -> [[c]] +mutRecCats = -} --- Use the strongly regular grammar to finite automaton --- compilation algorithm from \"Regular Approximation of Context-free --- Grammars through Approximation\", Mohri and Nederhof, 2000 +{- +-- | Get a map of categories to all categories which can occur in +-- the result of rewriting each category. +allCatsTrans :: CFRules -> FinitMap +allCatsTrans g c = +-} + +-- Convert a strongly regular grammar to a finite automaton. -- compileAutomaton :: +-- +-- CFG rule utilities +-- + +-- | Checks if a context-free rule is right-linear. +isRightLinear :: Eq c => [c] -- ^ The categories to consider + -> CFRule c n t -- ^ The rule to check for right-linearity + -> Bool +isRightLinear cs (CFRule _ ss _) = all (not . catElem cs) (safeInit ss) + +-- | Checks if a context-free rule is left-linear. +isLeftLinear :: Eq c => [c] -- ^ The categories to consider + -> CFRule c n t -- ^ The rule to check for right-linearity + -> Bool +isLeftLinear cs (CFRule _ ss _) = all (not . catElem cs) (drop 1 ss) + +-- | Checks if a symbol is a non-terminal of one of the given categories. +catElem :: Eq c => [c] -> Symbol c t -> Bool +catElem cs (Tok _) = False +catElem cs (Cat c) = c `elem` cs +-- | Check if any of the categories used on the right-hand side +-- are in the given list of categories. +anyUsedBy :: Eq c => [c] -> CFRule c n t -> Bool +anyUsedBy cs (CFRule _ ss _) = any (catElem cs) ss + +-- +-- * Utilities +-- fix :: Eq a => (a -> a) -> a -> a fix f x = let x' = f x in if x' == x then x else fix f x' @@ -124,3 +155,7 @@ fix f x = let x' = f x in if x' == x then x else fix f x' nothingOrNull :: Maybe [a] -> Bool nothingOrNull Nothing = True nothingOrNull (Just xs) = null xs + +safeInit :: [a] -> [a] +safeInit [] = [] +safeInit xs = init xs |