Added GSL speech recognition grammar generation.

1 files changed, 126 insertions, 0 deletions

diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs
new file mode 100644
index 000000000..58271ec2c
--- /dev/null
+++ b/src/GF/Speech/PrGSL.hs
@@ -0,0 +1,126 @@
+{- 
+   **************************************************************
+    GF Module
+   
+    Description   : This module prints a CFG as a Nuance GSL 2.0
+                    grammar.
+
+    Author        : Björn Bringert (bringert@cs.chalmers.se)
+
+    License       : GPL (GNU General Public License)
+
+    Created       : September 13, 2004
+
+    Modified      : 
+   ************************************************************** 
+-}
+
+-- FIXME: this modules should not be in cfgm, but where?
+
+-- FIXME: remove left-recursion
+
+-- FIXME: remove empty rules
+
+-- FIXME: remove categories with no RHS
+
+-- FIXME: remove / warn / fail if there are int / string literal
+-- categories in the grammar
+
+-- FIXME: figure out name prefix from grammar name
+
+module PrGSL (prGSL) where
+
+import Ident
+import CFGrammar
+import Parser (Symbol(..))
+import GrammarTypes
+import PrintParser
+import TransformCFG
+
+import Data.List
+import Data.FiniteMap
+
+
+type GSLGrammar = [GSLRule]
+data GSLRule = GSLRule String [GSLAlt]
+type GSLAlt = [Symbol String Token]
+
+type CatNames = FiniteMap String String
+
+prGSL :: CFGrammar -> String
+prGSL cfg = prGSLGrammar names gsl ""
+    where
+    cfg' = makeNice cfg
+    gsl = cfgToGSL cfg'
+    names = mkCatNames "GSL_" gsl
+
+cfgToGSL :: [CFRule_] -> GSLGrammar
+cfgToGSL = map cfgRulesToGSLRule . sortAndGroupBy ruleCat
+    where
+    ruleCat (Rule c _ _) = c
+    ruleRhs (Rule _ r _) = r
+    cfgRulesToGSLRule rs@(r:_) = GSLRule (ruleCat r) (map ruleRhs rs)
+
+mkCatNames :: String -- name prefix
+	   -> GSLGrammar -> CatNames
+mkCatNames pref gsl = listToFM (zip lhsCats names)
+    where names = [pref ++ show x | x <- [0..]]
+	  lhsCats = [ c | GSLRule c _ <- gsl ]
+
+prGSLGrammar :: CatNames -> GSLGrammar -> ShowS
+prGSLGrammar names g = header . unlinesS (map prGSLrule g)
+    where
+    header = showString ";GSL2.0" . nl
+    prGSLrule (GSLRule cat rhs) = 
+      showString "; " . prtS cat . nl
+        . prGSLCat cat . sp . wrap "[" (unwordsS (map prGSLAlt rhs)) "]" . nl
+    prGSLAlt rhs = wrap "(" (unwordsS (map prGSLSymbol rhs')) ")"
+		   where rhs' = rmPunct rhs
+    prGSLSymbol (Cat c) = prGSLCat c
+    prGSLSymbol (Tok t) = wrap "\"" (prtS t) "\""
+    prGSLCat c = showString n 
+	where n = case lookupFM names c of
+		    Nothing -> error $ "Unknown category: " ++ c
+		    Just x -> x
+
+rmPunct :: [Symbol String Token] -> [Symbol String Token] 
+rmPunct [] = []
+rmPunct (Tok t:ss) | all isPunct (prt t) = rmPunct ss
+rmPunct (s:ss) = s : rmPunct ss
+
+isPunct :: Char -> Bool
+isPunct c = c `elem` "-_.;.,?!"
+
+--
+-- * Utils
+--
+
+nl :: ShowS
+nl = showChar '\n'
+
+sp :: ShowS
+sp = showChar ' '
+
+wrap :: String -> ShowS -> String -> ShowS
+wrap o s c = showString o . s . showString c
+
+concatS :: [ShowS] -> ShowS
+concatS = foldr (.) id
+
+unwordsS :: [ShowS] -> ShowS
+unwordsS = concatS . intersperse sp 
+
+unlinesS :: [ShowS] -> ShowS
+unlinesS = concatS . intersperse nl
+
+sortAndGroupBy :: Ord b => 
+		  (a -> b) -- ^ Gets the value to sort and group by
+	       -> [a] 
+	       -> [[a]]
+sortAndGroupBy f = groupBy (both (==) f) . sortBy (both compare f)
+
+both :: (b -> b -> c) -> (a -> b) -> a -> a -> c
+both f g x y = f (g x) (g y)
+
+prtS :: Print a => a -> ShowS
+prtS = showString . prt
\ No newline at end of file