Added beginnings of ATK SLF generation.

6 files changed, 115 insertions, 18 deletions

diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs
index 14fb4c58e..8ddf0a521 100644
--- a/src/GF/Speech/PrGSL.hs
+++ b/src/GF/Speech/PrGSL.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:23:31 $ 
+-- > CVS $Date: 2005/06/17 12:46:04 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.18 $
+-- > CVS $Revision: 1.19 $
 --
 -- This module prints a CFG as a Nuance GSL 2.0 grammar.
 --
@@ -18,6 +18,7 @@
 module GF.Speech.PrGSL (gslPrinter) where
 
 import GF.Speech.SRG
+import GF.Speech.TransformCFG
 import GF.Infra.Ident
 
 import GF.Formalism.CFG
@@ -31,7 +32,7 @@ import Data.Char (toUpper,toLower)
 gslPrinter :: Ident -- ^ Grammar name
 	   -> Options -> CGrammar -> String
 gslPrinter name opts cfg = prGSL srg ""
-    where srg = makeSRG name opts cfg
+    where srg = makeSRG name opts (makeNice cfg)
 
 prGSL :: SRG -> ShowS
 prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
diff --git a/src/GF/Speech/PrJSGF.hs b/src/GF/Speech/PrJSGF.hs
index 58a33a324..8b73a080a 100644
--- a/src/GF/Speech/PrJSGF.hs
+++ b/src/GF/Speech/PrJSGF.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:23:31 $ 
+-- > CVS $Date: 2005/06/17 12:46:05 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.12 $
+-- > CVS $Revision: 1.13 $
 --
 -- This module prints a CFG as a JSGF grammar.
 --
@@ -20,6 +20,7 @@
 module GF.Speech.PrJSGF (jsgfPrinter) where
 
 import GF.Speech.SRG
+import GF.Speech.TransformCFG
 import GF.Infra.Ident
 import GF.Formalism.CFG
 import GF.Formalism.Utilities (Symbol(..))
@@ -30,7 +31,7 @@ import GF.Infra.Option
 jsgfPrinter :: Ident -- ^ Grammar name
 	   -> Options -> CGrammar -> String
 jsgfPrinter name opts cfg = prJSGF srg ""
-    where srg = makeSRG name opts cfg
+    where srg = makeSRG name opts (makeNice cfg)
 
 prJSGF :: SRG -> ShowS
 prJSGF (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs
new file mode 100644
index 000000000..044a94ed0
--- /dev/null
+++ b/src/GF/Speech/PrSLF.hs
@@ -0,0 +1,69 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : PrSLF
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/06/17 12:46:05 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- This module converts a CFG to an SLF finite-state network
+-- for use with the ATK recognizer. The SLF format is described
+-- in the HTK manual, and an example for use in ATK is shown
+-- in the ATK manual.
+--
+-- FIXME: remove \/ warn \/ fail if there are int \/ string literal
+-- categories in the grammar
+-----------------------------------------------------------------------------
+
+module GF.Speech.PrSLF (slfPrinter) where
+
+import GF.Speech.SRG
+import GF.Speech.TransformCFG
+import GF.Infra.Ident
+
+import GF.Formalism.CFG
+import GF.Formalism.Utilities (Symbol(..))
+import GF.Conversion.Types
+import GF.Infra.Print
+import GF.Infra.Option
+
+import Data.Char (toUpper,toLower)
+
+data SLF = SLF [SLFNode] [SLFEdge]
+
+data SLFNode = SLFNode Int SLFWord
+
+type SLFWord = Maybe String
+
+data SLFEdge = SLFEdge Int Int Int
+
+
+slfPrinter :: Ident -- ^ Grammar name
+	   -> Options -> CGrammar -> String
+slfPrinter name opts cfg = prSLF slf ""
+    where gr = makeNice cfg
+	  gr' = makeRegular gr
+	  srg = makeSRG name opts gr'
+	  slf = srg2slf srg
+
+srg2slf :: SRG -> SLF
+srg2slf = undefined
+
+prSLF :: SLF -> ShowS
+prSLF (SLF ns es) = header . unlinesS (map prNode ns) . unlinesS (map prEdge es)
+    where
+    header = showString "VERSION=1.0" . nl 
+	     . prFields [("N",show (length ns)),("L", show (length es))] . nl
+    prNode (SLFNode i w) = prFields [("I",show i),("W",showWord w)]
+    prEdge (SLFEdge i s e) = prFields [("J",show i),("S",show s),("E",show e)]
+
+
+showWord :: SLFWord -> String
+showWord Nothing = "!NULL"
+showWord (Just w) = w -- FIXME: convert words to upper case
+
+prFields :: [(String,String)] -> ShowS
+prFields fs = unwordsS [ showString l . showChar '=' . showString v | (l,v) <- fs ]
diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs
index d59a391a1..2594e0a3e 100644
--- a/src/GF/Speech/SRG.hs
+++ b/src/GF/Speech/SRG.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:23:32 $ 
+-- > CVS $Date: 2005/06/17 12:46:05 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.13 $
+-- > CVS $Revision: 1.14 $
 --
 -- Representation of, conversion to, and utilities for 
 -- printing of a general Speech Recognition Grammar. 
@@ -53,7 +53,7 @@ type CatNames = FiniteMap String String
 
 makeSRG :: Ident     -- ^ Grammar name
 	-> Options   -- ^ Grammar options
-	-> CGrammar -- ^ A context-free grammar
+	-> [CFRule_] -- ^ A context-free grammar
 	-> SRG
 makeSRG i opts gr = SRG { grammarName = name,
 			  startCat = start,
@@ -63,9 +63,8 @@ makeSRG i opts gr = SRG { grammarName = name,
     name = prIdent i
     origStart = fromMaybe "S" (getOptVal opts gStartCat) ++ "{}.s"
     start = lookupFM_ names origStart
-    gr' = makeNice gr
-    names = mkCatNames name (nub $ map ruleCat gr')
-    rs = map (cfgRulesToSRGRule names) (sortAndGroupBy ruleCat gr')
+    names = mkCatNames name (nub $ map ruleCat gr)
+    rs = map (cfgRulesToSRGRule names) (sortAndGroupBy ruleCat gr)
 
 cfgRulesToSRGRule :: FiniteMap String String -> [CFRule_] -> SRGRule
 cfgRulesToSRGRule names rs@(r:_) = SRGRule cat origCat rhs
diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs
index 71b3ca296..db9b009a6 100644
--- a/src/GF/Speech/TransformCFG.hs
+++ b/src/GF/Speech/TransformCFG.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:23:33 $ 
+-- > CVS $Date: 2005/06/17 12:46:05 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.12 $
+-- > CVS $Revision: 1.13 $
 --
 --  This module does some useful transformations on CFGs.
 --
@@ -16,7 +16,7 @@
 -- peb thinks: most of this module should be moved to GF.Conversion...
 -----------------------------------------------------------------------------
 
-module GF.Speech.TransformCFG (makeNice, CFRule_) where
+module GF.Speech.TransformCFG (makeNice, CFRule_, makeRegular) where
 
 import GF.Infra.Ident
 import GF.Formalism.CFG 
@@ -37,6 +37,8 @@ type Cat_ = String
 
 type CFRules = FiniteMap Cat_ [CFRule_]
 
+-- | Remove left-recursion and categories with no productions
+--   from a context-free grammar.
 makeNice :: CGrammar -> [CFRule_]
 makeNice = concat . eltsFM . makeNice' . groupProds . cfgToCFRules
     where makeNice' = removeLeftRecursion . removeEmptyCats
@@ -94,6 +96,27 @@ isDirectLeftRecursive (CFRule c (Cat c':_) _) = c == c'
 isDirectLeftRecursive _ = False
 
 
+-- Use the transformation algorithm from \"Regular Approximation of Context-free
+-- Grammars through Approximation\", Mohri and Nederhof, 2000
+-- to create an over-generating regular frammar for a context-free 
+-- grammar
+makeRegular :: [CFRule_] -> [CFRule_]
+makeRegular = undefined
+
+{-
+isRightLinear :: [Cat_] -- ^ The categories to consider
+	      -> CFRule_ 
+	      -> Bool
+isRightLinear _  (CFRule _ ss _) | all isTerminal ss = True
+isRightLinear cs 
+-}
+
+-- Use the strongly regular grammar to finite automaton
+-- compilation algorithm from \"Regular Approximation of Context-free
+-- Grammars through Approximation\", Mohri and Nederhof, 2000
+-- compileAutomaton :: 
+
+
 
 fix :: Eq a => (a -> a) -> a -> a
 fix f x = let x' = f x in if x' == x then x else fix f x'
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 08136fad8..e158a19c4 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/src/GF/UseGrammar/Custom.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/17 11:20:25 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.63 $
+-- > CVS $Date: 2005/06/17 12:46:05 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.64 $
 --
 -- A database for customizable GF shell commands. 
 --
@@ -56,6 +56,7 @@ import GF.Canon.MkGFC
 import GF.CF.CFtoSRG
 import GF.Speech.PrGSL (gslPrinter)
 import GF.Speech.PrJSGF (jsgfPrinter)
+import GF.Speech.PrSLF (slfPrinter)
 
 import GF.Data.Zipper
 
@@ -233,6 +234,9 @@ customGrammarPrinter =
   ,(strCI "jsgf",    \s -> let opts = stateOptions s
                                name = cncId s
                             in jsgfPrinter name opts $ stateCFG s)
+  ,(strCI "slf",     \s -> let opts = stateOptions s
+                               name = cncId s
+                            in slfPrinter name opts $ stateCFG s)
   ,(strCI "plbnf",   prLBNF True)
   ,(strCI "lbnf",    prLBNF False)
   ,(strCI "bnf",     prBNF False)