diff --git a/src-3.0/GF/Speech/CFG.hs b/src-3.0/GF/Speech/CFG.hs index 98d31c9f6..a99a9d011 100644 --- a/src-3.0/GF/Speech/CFG.hs +++ b/src-3.0/GF/Speech/CFG.hs @@ -80,12 +80,13 @@ bottomUpFilter gr = fix grow (gr { cfgRules = Map.empty }) where grow g = g `unionCFG` filterCFG (all (okSym g) . ruleRhs) gr okSym g = symbol (`elem` allCats g) (const True) --- | Removes categories which are not reachable from the start category. +-- | Removes categories which are not reachable from any external category. topDownFilter :: CFG -> CFG -topDownFilter cfg = filterCFGCats (isRelatedTo uses (cfgStartCat cfg)) cfg +topDownFilter cfg = filterCFGCats (`Set.member` keep) cfg where rhsCats = [ (lhsCat r, c') | r <- allRules cfg, c' <- filterCats (ruleRhs r) ] uses = reflexiveClosure_ (allCats cfg) $ transitiveClosure $ mkRel rhsCats + keep = Set.unions $ map (allRelated uses) $ Set.toList $ cfgExternalCats cfg -- | Merges categories with identical right-hand-sides. -- FIXME: handle probabilities diff --git a/src-3.0/GF/Speech/JSGF.hs b/src-3.0/GF/Speech/JSGF.hs index 53a40ffd4..d49646152 100644 --- a/src-3.0/GF/Speech/JSGF.hs +++ b/src-3.0/GF/Speech/JSGF.hs @@ -44,8 +44,10 @@ prJSGF sisr srg comment "Generated by GF" $$ text ("grammar " ++ srgName srg ++ ";") lang = maybe empty text (srgLanguage srg) - mainCat = rule True "MAIN" [prCat (srgStartCat srg)] - prRule (SRGRule cat rhs) = rule (isExternalCat srg cat) cat (map prAlt rhs) + mainCat = rule True "MAIN" [prCat (externalCat (srgStartCat srg))] + prRule (SRGRule cat rhs) + | isExternalCat srg cat = rule True (externalCat cat) (map prAlt rhs) + | otherwise = rule False cat (map prAlt rhs) prAlt (SRGAlt mp n rhs) = sep [initTag, p (prItem sisr n rhs), finalTag] where initTag | isEmpty t = empty | otherwise = text "" <+> t @@ -53,8 +55,8 @@ prJSGF sisr srg finalTag = tag sisr (profileFinalSISR n) p = if isEmpty initTag && isEmpty finalTag then id else parens -catFormId :: String -> String -catFormId = (++ "_cat") +externalCat :: Cat -> Cat +externalCat c = c ++ "_cat" prCat :: Cat -> Doc prCat c = char '<' <> text c <> char '>' diff --git a/src-3.0/GF/Speech/PGFToCFG.hs b/src-3.0/GF/Speech/PGFToCFG.hs index a2dc32f32..168591e6b 100644 --- a/src-3.0/GF/Speech/PGFToCFG.hs +++ b/src-3.0/GF/Speech/PGFToCFG.hs @@ -45,16 +45,20 @@ pgfToCFG pgf lang = mkCFG (lookStartCat pgf) extCats (startRules ++ concatMap fr -- NOTE: this is only correct for cats that have a lincat with exactly one row. startRules :: [CFRule] startRules = [CFRule (prCId c) [NonTerminal (fcatToCat fc 0)] (CFRes 0) - | (c,fcs) <- Map.toList (startupCats pinfo), fc <- fcs] + | (c,fcs) <- Map.toList (startupCats pinfo), + fc <- fcs, not (isLiteralFCat fc)] fruleToCFRule :: FRule -> [CFRule] fruleToCFRule (FRule f ps args c rhs) = [CFRule (fcatToCat c l) (mkRhs row) (profilesToTerm (map (fixProfile row) ps)) - | (l,row) <- Array.assocs rhs] + | (l,row) <- Array.assocs rhs, not (containsLiterals row)] where mkRhs :: Array FPointPos FSymbol -> [CFSymbol] mkRhs = map fsymbolToSymbol . Array.elems + containsLiterals :: Array FPointPos FSymbol -> Bool + containsLiterals row = any isLiteralFCat [args!!n | FSymCat _ n <- Array.elems row] + fsymbolToSymbol :: FSymbol -> CFSymbol fsymbolToSymbol (FSymCat l n) = NonTerminal (fcatToCat (args!!n) l) fsymbolToSymbol (FSymTok t) = Terminal t @@ -73,3 +77,6 @@ pgfToCFG pgf lang = mkCFG (lookStartCat pgf) extCats (startRules ++ concatMap fr profileToTerm :: CId -> Profile -> CFTerm profileToTerm t [] = CFMeta t profileToTerm _ xs = CFRes (last xs) -- FIXME: unify + +isLiteralFCat :: FCat -> Bool +isLiteralFCat = (`elem` [fcatString, fcatInt, fcatFloat, fcatVar]) diff --git a/src-3.0/GF/Speech/SRG.hs b/src-3.0/GF/Speech/SRG.hs index 8bb509d22..defd647d7 100644 --- a/src-3.0/GF/Speech/SRG.hs +++ b/src-3.0/GF/Speech/SRG.hs @@ -90,7 +90,8 @@ makeSimpleSRG = makeSRG preprocess traceStats s g = trace ("---- " ++ s ++ ": " ++ stats g {- ++ "\n" ++ prCFRules g ++ "----" -}) g stats g = "Categories: " ++ show (countCats g) - ++ " Rules: " ++ show (countRules g) + ++ ", External categories: " ++ show (Set.size (cfgExternalCats g)) + ++ ", Rules: " ++ show (countRules g) makeNonRecursiveSRG :: PGF -> CId -- ^ Concrete syntax name. diff --git a/src-3.0/GF/Speech/SRGS_XML.hs b/src-3.0/GF/Speech/SRGS_XML.hs index 97c1629fb..e78a702da 100644 --- a/src-3.0/GF/Speech/SRGS_XML.hs +++ b/src-3.0/GF/Speech/SRGS_XML.hs @@ -32,16 +32,19 @@ srgsXmlNonRecursivePrinter pgf cnc = prSrgsXml Nothing $ makeNonRecursiveSRG pgf prSrgsXml :: Maybe SISRFormat -> SRG -> String prSrgsXml sisr srg = showXMLDoc (optimizeSRGS xmlGr) where - xmlGr = grammar sisr (srgStartCat srg) (srgLanguage srg) $ + xmlGr = grammar sisr (externalCat (srgStartCat srg)) (srgLanguage srg) $ [meta "description" ("SRGS XML speech recognition grammar for " ++ srgName srg ++ "."), meta "generator" "Grammatical Framework"] ++ map ruleToXML (srgRules srg) - ruleToXML (SRGRule cat alts) = Tag "rule" ([("id",cat)]++pub) (prRhs alts) - where pub | isExternalCat srg cat = [("scope","public")] - | otherwise = [] + ruleToXML (SRGRule cat alts) + | isExternalCat srg cat = Tag "rule" [("id",externalCat cat),("scope","public")] (prRhs alts) + | otherwise = Tag "rule" [("id",cat)] (prRhs alts) prRhs rhss = [oneOf (map (mkProd sisr) rhss)] +externalCat :: Cat -> Cat +externalCat c = c ++ "_cat" + mkProd :: Maybe SISRFormat -> SRGAlt -> XML mkProd sisr (SRGAlt mp n rhs) = Tag "item" [] (ti ++ [x] ++ tf) where x = mkItem sisr n rhs