From ebb3382418222d0140f1f84ee86c5bb961a2f519 Mon Sep 17 00:00:00 2001 From: bringert Date: Tue, 12 Dec 2006 11:59:12 +0000 Subject: [PATCH] Moved profile stuff to GF.Speech.SRG, to allow other SRG formats to include SISR. --- src/GF/Speech/PrGSL.hs | 2 +- src/GF/Speech/PrJSGF.hs | 4 ++-- src/GF/Speech/PrSRGS.hs | 30 ++++++++++-------------------- src/GF/Speech/SRG.hs | 39 +++++++++++++++++++++++++++------------ 4 files changed, 40 insertions(+), 35 deletions(-) diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs index ffcd00509..d9e248499 100644 --- a/src/GF/Speech/PrGSL.hs +++ b/src/GF/Speech/PrGSL.hs @@ -50,7 +50,7 @@ prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) . prCat cat . sp . wrap "[" (unwordsS (map prAlt rhs)) "]" . nl -- FIXME: use the probability prAlt (SRGAlt mp _ rhs) = wrap "(" (unwordsS (map prSymbol rhs)) ")" - prSymbol (Cat c) = prCat c + prSymbol (Cat (c,_)) = prCat c prSymbol (Tok t) = wrap "\"" (showString (showToken t)) "\"" -- GSL requires an upper case letter in category names prCat c = showString (firstToUpper c) diff --git a/src/GF/Speech/PrJSGF.hs b/src/GF/Speech/PrJSGF.hs index 2a4c4fd51..6183b9826 100644 --- a/src/GF/Speech/PrJSGF.hs +++ b/src/GF/Speech/PrJSGF.hs @@ -54,11 +54,11 @@ prJSGF (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) | null rhs' = showString "" | otherwise = wrap "(" (unwordsS (map prSymbol rhs')) ")" where rhs' = rmPunct rhs - prSymbol (Cat c) = prCat c + prSymbol (Cat (c,_)) = prCat c prSymbol (Tok t) = wrap "\"" (prtS t) "\"" prCat c = showChar '<' . showString c . showChar '>' -rmPunct :: [Symbol String Token] -> [Symbol String Token] +rmPunct :: [Symbol c Token] -> [Symbol c Token] rmPunct [] = [] rmPunct (Tok t:ss) | all isPunct (prt t) = rmPunct ss rmPunct (s:ss) = s : rmPunct ss diff --git a/src/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs index 2d401bb4a..27f085cff 100644 --- a/src/GF/Speech/PrSRGS.hs +++ b/src/GF/Speech/PrSRGS.hs @@ -88,18 +88,14 @@ mkProd :: Maybe SISRFormat -> Bool -> SRGAlt -> XML mkProd sisr isList (SRGAlt p n@(Name f pr) rhs) = prodItem sisr n p (r ++ if isList then [tag sisr buildList] else []) where - r = map (uncurry (symItem sisr pr)) (numberCats 0 rhs) + r = map (symItem sisr) rhs buildList | isBase f = [EThis := (ENew "Array" args)] | isCons f = [EApp (EThis :. "arg1" :. "unshift") [EThis :. "arg0"], EThis := (EThis :. "arg1")] where args = [EThis :. ("arg"++show n) | n <- [0..length pr-1]] - numberCats _ [] = [] - numberCats n (s@(Cat _):ss) = (s,n):numberCats (n+1) ss - numberCats n (s:ss) = (s,n):numberCats n ss - prodItem :: Maybe SISRFormat -> Name -> Maybe Double -> [XML] -> XML -prodItem sisr n mp xs = Tag "item" w (cs++t) +prodItem sisr n mp xs = Tag "item" w (t++cs) where w = maybe [] (\p -> [("weight", show p)]) mp t = prodTag sisr n @@ -111,28 +107,22 @@ prodTag :: Maybe SISRFormat -> Name -> [XML] prodTag sisr (Name f prs) = [tag sisr ts] where ts = [(EThis :. "name") := (EStr (prIdent f))] ++ - [(EThis :. ("arg" ++ show n)) := (EStr v) - | n <- [0..length prs-1], v <- argInit (prs!!n)] - argInit (Unify []) = ["?"] - argInit (Unify _) = [] - argInit (Constant f) = [maybe "?" prIdent (forestName f)] + [(EThis :. ("arg" ++ show n)) := (EStr (argInit (prs!!n))) + | n <- [0..length prs-1]] + argInit (Unify _) = "?" + argInit (Constant f) = maybe "?" prIdent (forestName f) -symItem :: Maybe SISRFormat -> [Profile a] -> Symbol String Token -> Int -> XML -symItem sisr prs (Cat c) x = Tag "item" [] ([Tag "ruleref" [("uri","#" ++ prCat c)] []]++t) +symItem :: Maybe SISRFormat -> Symbol SRGNT Token -> XML +symItem sisr (Cat (c,slots)) = Tag "item" [] ([Tag "ruleref" [("uri","#" ++ prCat c)] []]++t) where t = if null ts then [] else [tag sisr ts] - ts = [(EThis :. ("arg" ++ show n)) := (ERef (prCat c)) - | n <- [0..length prs-1], inProfile x (prs!!n)] -symItem _ _ (Tok t) _ = Tag "item" [] [Data (showToken t)] + ts = [(EThis :. ("arg" ++ show s)) := (ERef (prCat c)) | s <- slots] +symItem _ (Tok t) = Tag "item" [] [Data (showToken t)] tag :: Maybe SISRFormat -> [SISRExpr] -> XML tag Nothing _ = Empty tag (Just fmt) ts = Tag "tag" [] [Data (join "; " (map (prSISR fmt) ts))] -inProfile :: Int -> Profile a -> Bool -inProfile x (Unify xs) = x `elem` xs -inProfile _ (Constant _) = False - prCat :: String -> String prCat c = c diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs index 2dd41cfaf..b55475f1f 100644 --- a/src/GF/Speech/SRG.hs +++ b/src/GF/Speech/SRG.hs @@ -19,6 +19,7 @@ ----------------------------------------------------------------------------- module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..), + SRGCat, SRGNT, makeSimpleSRG, makeSRG , lookupFM_, prtS , topDownFilter) where @@ -28,7 +29,8 @@ import GF.Data.Utilities import GF.Infra.Ident import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..), NameProfile(..) - , Profile, SyntaxForest, filterCats) + , Profile(..), SyntaxForest + , filterCats, mapSymbol) import GF.Conversion.Types import GF.Infra.Print import GF.Speech.TransformCFG @@ -52,16 +54,21 @@ data SRG = SRG { grammarName :: String -- ^ grammar name } deriving (Eq,Show) -data SRGRule = SRGRule String String [SRGAlt] -- ^ SRG category name, original category name +data SRGRule = SRGRule SRGCat String [SRGAlt] -- ^ SRG category name, original category name -- and productions deriving (Eq,Show) -- | maybe a probability, a rule name and a list of symbols -data SRGAlt = SRGAlt (Maybe Double) Name [Symbol String Token] +data SRGAlt = SRGAlt (Maybe Double) Name [Symbol SRGNT Token] deriving (Eq,Show) +type SRGCat = String + +-- | An SRG non-terminal. Category name and slots which it fills in. +type SRGNT = (SRGCat, [Int]) + -- | SRG category name and original name -type CatName = (String,String) +type CatName = (SRGCat,String) type CatNames = Map String String @@ -112,13 +119,21 @@ makeSRG_ f i origStart opts probs gr -- FIXME: merge alternatives with same rhs and profile but different probabilities cfgRulesToSRGRule :: Map String String -> Maybe Probs -> [CFRule_] -> SRGRule cfgRulesToSRGRule names probs rs@(r:_) = SRGRule cat origCat rhs - where origCat = lhsCat r - cat = lookupFM_ names origCat - rhs = nub $ map ruleToAlt rs - ruleToAlt r@(CFRule c ss n) - = SRGAlt (ruleProb probs r) n (map renameCat ss) - renameCat (Cat c) = Cat (lookupFM_ names c) - renameCat t = t + where + origCat = lhsCat r + cat = lookupFM_ names origCat + rhs = nub $ map ruleToAlt rs + ruleToAlt r@(CFRule c ss n@(Name _ prs)) + = SRGAlt (ruleProb probs r) n (mkSRGSymbols 0 ss) + where + mkSRGSymbols _ [] = [] + mkSRGSymbols i (Cat c:ss) = Cat (c',slots) : mkSRGSymbols (i+1) ss + where c' = lookupFM_ names c + slots = [x | x <- [0..length prs-1], inProfile i (prs!!x)] + mkSRGSymbols i (Tok t:ss) = Tok t : mkSRGSymbols i ss + inProfile :: Int -> Profile a -> Bool + inProfile x (Unify xs) = x `elem` xs + inProfile _ (Constant _) = False ruleProb :: Maybe Probs -> CFRule_ -> Maybe Double ruleProb mp r = mp >>= \probs -> lookupProb probs (ruleFun r) @@ -141,7 +156,7 @@ topDownFilter srg@(SRG { startCat = start, rules = rs }) = srg { rules = rs' } rs' = [ r | r@(SRGRule c _ _) <- rs, c `Set.member` keep] rhsCats = [ (c,c') | r@(SRGRule c _ ps) <- rs, SRGAlt _ _ ss <- ps, - c' <- filterCats ss] + (c',_) <- filterCats ss] uses = reflexiveClosure_ (allSRGCats srg) $ transitiveClosure $ mkRel rhsCats keep = allRelated uses start