diff options
Diffstat (limited to 'src/GF/Speech/PrSRGS.hs')
| -rw-r--r-- | src/GF/Speech/PrSRGS.hs | 71 |
1 files changed, 8 insertions, 63 deletions
diff --git a/src/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs index 9f86c1468..63ca91034 100644 --- a/src/GF/Speech/PrSRGS.hs +++ b/src/GF/Speech/PrSRGS.hs @@ -15,6 +15,7 @@ module GF.Speech.PrSRGS (SISRFormat(..), srgsXmlPrinter) where import GF.Data.Utilities import GF.Data.XML +import GF.Speech.RegExp import GF.Speech.SISR as SISR import GF.Speech.SRG import GF.Infra.Ident @@ -85,9 +86,12 @@ mkProd sisr (EBnfSRGAlt mp n@(Name f prs) rhs) = Tag "item" w (t ++ xs) argInit (Constant f) = maybe "?" prIdent (forestName f) mkItem :: Maybe SISRFormat -> EBnfSRGItem -> XML -mkItem sisr (EBnfOneOf xs) = oneOf (map (mkItem sisr) xs) -mkItem sisr (EBnfSeq xs) = Tag "item" [] (map (mkItem sisr) xs) -mkItem sisr (EBnfSymbol s) = symItem sisr s +mkItem sisr = f + where + f (REUnion xs) = oneOf (map f xs) + f (REConcat xs) = Tag "item" [] (map f xs) + f (RERepeat x) = Tag "item" [("repeat","0-")] [f x] + f (RESymbol s) = symItem sisr s symItem :: Maybe SISRFormat -> Symbol SRGNT Token -> XML symItem sisr (Cat (c,slots)) = Tag "item" [] ([Tag "ruleref" [("uri","#" ++ prCat c)] []]++t) @@ -107,8 +111,7 @@ showToken :: Token -> String showToken t = t oneOf :: [XML] -> XML -oneOf [x] = x -oneOf xs = Tag "one-of" [] xs +oneOf = Tag "one-of" [] grammar :: Maybe SISRFormat -> String -- ^ root @@ -130,61 +133,3 @@ optimizeSRGS = bottomUpXML f where f (Tag "item" [] [x@(Tag "item" [] _)]) = x f (Tag "one-of" [] [x]) = x f x = x - -{- - --- --- * SRGS minimization --- - -minimizeRule :: XML -> XML -minimizeRule (Tag "rule" attrs cs) - = Tag "rule" attrs (map minimizeOneOf cs) - -minimizeOneOf :: XML -> XML -minimizeOneOf (Tag "one-of" attrs cs) - = Tag "item" [] (p++[Tag "one-of" attrs cs']) - where - (pref,cs') = factor cs - p = if null pref then [] else [Tag "one-of" [] pref] -minimizeOneOf x = x - -factor :: [XML] -> ([XML],[XML]) -factor xs = case f of - Just (ps,xs') -> (map it ps, map it xs') - Nothing -> ([],xs) - where - -- FIXME: maybe getting all the longest terminal prefixes - -- is not optimal? - f = cartesianFactor $ map (terminalPrefix . unIt) xs - unIt (Tag "item" [] cs) = cs - it cs = Tag "item" [] cs - -terminalPrefix :: [XML] -> ([XML],[XML]) -terminalPrefix cs = (terms, tags ++ cs'') - where (tags,cs') = span isTag cs - (terms,cs'') = span isTerminalItem cs' - -isTag :: XML -> Bool -isTag (Tag t _ _) = t == "tag" -isTag _ = False - -isTerminalItem :: XML -> Bool -isTerminalItem (Tag "item" [] [Data _]) = True -isTerminalItem _ = False - --- --- * Utilities --- - -allEqual :: Eq a => [a] -> Bool -allEqual [] = True -allEqual (x:xs) = all (x==) xs - -cartesianFactor :: (Ord a, Ord b) => [(a,b)] -> Maybe ([a],[b]) -cartesianFactor xs - | not (null es) && allEqual es = Just (Map.keys m, Set.elems (head es)) - | otherwise = Nothing - where m = Map.fromListWith Set.union [(x,Set.singleton y) | (x,y) <- xs] - es = Map.elems m --}
\ No newline at end of file |
