Some baby stpes closes to ATK SLF generation.

src/GF/Speech/PrSLF.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/17 12:46:05 $ 
+-- > CVS $Date: 2005/09/02 15:47:46 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- This module converts a CFG to an SLF finite-state network
 -- for use with the ATK recognizer. The SLF format is described
@@ -32,38 +32,36 @@ import GF.Infra.Option
 
 import Data.Char (toUpper,toLower)
 
-data SLF = SLF [SLFNode] [SLFEdge]
+data SLF = SLF { slfNodes :: [SLFNode], slfEdges :: [SLFEdge] }
 
-data SLFNode = SLFNode Int SLFWord
+data SLFNode = SLFNode { nId :: Int, nWord :: SLFWord }
 
-type SLFWord = Maybe String
+-- | An SLF word is a word, or the empty string.
+type SLFWord = String
 
-data SLFEdge = SLFEdge Int Int Int
+data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: 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
+    where slf = srg2slf $ makeSRG name opts $ makeRegular $ makeNice cfg
 
 srg2slf :: SRG -> SLF
-srg2slf = undefined
+srg2slf = undefined -- should use TransformCFG.compileAutomaton
 
 prSLF :: SLF -> ShowS
-prSLF (SLF ns es) = header . unlinesS (map prNode ns) . unlinesS (map prEdge es)
+prSLF (SLF { slfNodes = ns, slfEdges = 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)]
+    prNode n = prFields [("I",show (nId n)),("W",showWord (nWord n))]
+    prEdge e = prFields [("J",show (eId e)),("S",show (eStart e)),("E",show (eEnd e))]
 
 
 showWord :: SLFWord -> String
-showWord Nothing = "!NULL"
-showWord (Just w) = w -- FIXME: convert words to upper case
+showWord "" = "!NULL"
+showWord w = w -- FIXME: convert words to upper case
 
 prFields :: [(String,String)] -> ShowS
 prFields fs = unwordsS [ showString l . showChar '=' . showString v | (l,v) <- fs ]

src/GF/Speech/TransformCFG.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/17 12:46:05 $ 
+-- > CVS $Date: 2005/09/02 15:47:47 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.13 $
+-- > CVS $Revision: 1.14 $
 --
 --  This module does some useful transformations on CFGs.
 --
@@ -40,7 +40,7 @@ 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
+makeNice = ungroupProds . makeNice' . groupProds . cfgToCFRules
     where makeNice' = removeLeftRecursion . removeEmptyCats
 
 cfgToCFRules :: CGrammar -> [CFRule_]
@@ -55,6 +55,9 @@ groupProds :: [CFRule_] -> CFRules
 groupProds = addListToFM_C (++) emptyFM . map (\rs -> (ruleCat rs,[rs]))
     where ruleCat (CFRule c _ _) = c
 
+ungroupProds :: CFRules -> [CFRule_]
+ungroupProds = concat . eltsFM
+
 -- | Remove productions which use categories which have no productions
 removeEmptyCats :: CFRules -> CFRules
 removeEmptyCats rss = listToFM $ fix removeEmptyCats' $ fmToList rss
@@ -67,9 +70,6 @@ removeEmptyCats rss = listToFM $ fix removeEmptyCats' $ fmToList rss
 	emptyCats = filter (nothingOrNull . flip lookup rs) allCats
 	k' = map (\ (c,xs) -> (c, filter (not . anyUsedBy emptyCats) xs)) keep
 
-anyUsedBy :: [Cat_] -> CFRule_ -> Bool
-anyUsedBy ss (CFRule _ r _) = or [c `elem` ss | Cat c <- r]
-
 removeLeftRecursion :: CFRules -> CFRules
 removeLeftRecursion rs = listToFM $ concatMap removeDirectLeftRecursion $ map handleProds $ fmToList rs
     where 
@@ -104,19 +104,50 @@ makeRegular :: [CFRule_] -> [CFRule_]
 makeRegular = undefined
 
 {-
-isRightLinear :: [Cat_] -- ^ The categories to consider
-	      -> CFRule_ 
-	      -> Bool
-isRightLinear _  (CFRule _ ss _) | all isTerminal ss = True
-isRightLinear cs 
+-- | Get the sets of mutually recursive non-terminals for a grammar.
+mutRecCats :: Eq c => [CFRule c n t] -> [[c]]
+mutRecCats = 
 -}
 
--- Use the strongly regular grammar to finite automaton
--- compilation algorithm from \"Regular Approximation of Context-free
--- Grammars through Approximation\", Mohri and Nederhof, 2000
+{-
+-- | Get a map of categories to all categories which can occur in 
+--   the result of rewriting each category.
+allCatsTrans :: CFRules -> FinitMap 
+allCatsTrans g c = 
+-}
+
+-- Convert a strongly regular grammar to a finite automaton.
 -- compileAutomaton :: 
 
+--
+-- CFG rule utilities
+--
 
+-- | Checks if a context-free rule is right-linear.
+isRightLinear :: Eq c => [c]  -- ^ The categories to consider
+	      -> CFRule c n t -- ^ The rule to check for right-linearity
+	      -> Bool
+isRightLinear cs (CFRule _ ss _) = all (not . catElem cs) (safeInit ss)
+
+-- | Checks if a context-free rule is left-linear.
+isLeftLinear ::  Eq c => [c]  -- ^ The categories to consider
+	      -> CFRule c n t -- ^ The rule to check for right-linearity
+	      -> Bool
+isLeftLinear cs (CFRule _ ss _) = all (not . catElem cs) (drop 1 ss)
+
+-- | Checks if a symbol is a non-terminal of one of the given categories.
+catElem :: Eq c => [c] -> Symbol c t -> Bool
+catElem cs (Tok _) = False
+catElem cs (Cat c) = c `elem` cs
+
+-- | Check if any of the categories used on the right-hand side
+--   are in the given list of categories.
+anyUsedBy :: Eq c => [c] -> CFRule c n t -> Bool
+anyUsedBy cs (CFRule _ ss _) = any (catElem cs) ss
+
+--
+-- * Utilities
+--
 
 fix :: Eq a => (a -> a) -> a -> a
 fix f x = let x' = f x in if x' == x then x else fix f x'
@@ -124,3 +155,7 @@ fix f x = let x' = f x in if x' == x then x else fix f x'
 nothingOrNull :: Maybe [a] -> Bool
 nothingOrNull Nothing = True
 nothingOrNull (Just xs) = null xs
+
+safeInit :: [a] -> [a]
+safeInit [] = []
+safeInit xs = init xs