Moved profile stuff to GF.Speech.SRG, to allow other SRG formats to include SISR.

4 files changed, 41 insertions, 36 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 "<NULL>"
 	| 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)]
-
-symItem :: Maybe SISRFormat -> [Profile a] -> Symbol String Token -> Int -> XML
-symItem sisr prs (Cat c) x = Tag "item" [] ([Tag "ruleref" [("uri","#" ++ prCat c)] []]++t)
+       [(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 -> 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