GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 09:32:53 -06:00
Code Issues Packages Projects Releases Wiki Activity

Change input to the different SRG printers to be StateGrammar instead of CGrammar. This to allow looking at the types in SISR, and to reduce the number of argument passed from Custom.

Browse Source
This commit is contained in:
bringert
2007-01-05 14:34:20 +00:00
parent 2b1c6763cc
commit 741dde5a2a
11 changed files with 105 additions and 92 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/GF/Data/XML.hs
View File

@@ -8,7 +8,7 @@
-- Utilities for creating XML documents. -- Utilities for creating XML documents.
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Data.XML (XML(..), Attr, comments, showsXMLDoc, showsXML, bottomUpXML) where module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
import GF.Data.Utilities import GF.Data.Utilities
@@ -20,6 +20,9 @@ type Attr = (String,String)
comments :: [String] -> [XML] comments :: [String] -> [XML]
comments = map Comment comments = map Comment
showXMLDoc :: XML -> String
showXMLDoc xml = showsXMLDoc xml ""
showsXMLDoc :: XML -> ShowS showsXMLDoc :: XML -> ShowS
showsXMLDoc xml = showString header . showsXML xml showsXMLDoc xml = showString header . showsXML xml
where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>" where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"

13
src/GF/Speech/CFGToFiniteState.hs
View File

@@ -27,6 +27,7 @@ import GF.Formalism.CFG
import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, NameProfile(..)) import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, NameProfile(..))
import GF.Conversion.Types import GF.Conversion.Types
import GF.Infra.Ident (Ident) import GF.Infra.Ident (Ident)
import GF.Compile.ShellState (StateGrammar)
import GF.Speech.FiniteState import GF.Speech.FiniteState
import GF.Speech.Graph import GF.Speech.Graph
@@ -56,10 +57,10 @@ data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))]
cfgToFA :: String -> CGrammar -> DFA String cfgToFA :: String -> StateGrammar -> DFA String
cfgToFA start = minimize . compileAutomaton start . makeSimpleRegular cfgToFA start = minimize . compileAutomaton start . makeSimpleRegular
makeSimpleRegular :: CGrammar -> CFRules makeSimpleRegular :: StateGrammar -> CFRules
makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgToCFRules makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgToCFRules
-- --
@@ -144,15 +145,15 @@ make_fa c@(g,ns) q0 alpha q1 fa =
-- * Compile a strongly regular grammar to a DFA with sub-automata -- * Compile a strongly regular grammar to a DFA with sub-automata
-- --
cfgToMFA :: String -> CGrammar -> MFA String cfgToMFA :: String -> StateGrammar -> MFA String
cfgToMFA start g = buildMFA start g cfgToMFA start g = buildMFA start g
-- | Build a DFA by building and expanding an MFA -- | Build a DFA by building and expanding an MFA
cfgToFA' :: String -> CGrammar -> DFA String cfgToFA' :: String -> StateGrammar -> DFA String
cfgToFA' start g = mfaToDFA $ cfgToMFA start g cfgToFA' start = mfaToDFA . cfgToMFA start
buildMFA :: Cat_ -- ^ Start category buildMFA :: Cat_ -- ^ Start category
-> CGrammar -> MFA String -> StateGrammar -> MFA String
buildMFA start g = sortSubLats $ removeUnusedSubLats mfa buildMFA start g = sortSubLats $ removeUnusedSubLats mfa
where startFA = let (fa,s,f) = newFA_ where startFA = let (fa,s,f) = newFA_
in newTransition s f (MFASub start) fa in newTransition s f (MFASub start) fa

15
src/GF/Speech/PrFA.hs
View File

@@ -28,6 +28,7 @@ import GF.Speech.CFGToFiniteState
import GF.Speech.FiniteState import GF.Speech.FiniteState
import GF.Speech.SRG import GF.Speech.SRG
import GF.Speech.TransformCFG import GF.Speech.TransformCFG
import GF.Compile.ShellState (StateGrammar)
import Data.Char (toUpper,toLower) import Data.Char (toUpper,toLower)
import Data.List import Data.List
@@ -36,14 +37,12 @@ import Data.Maybe (fromMaybe)
faGraphvizPrinter :: Ident -- ^ Grammar name faGraphvizPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String -> String -> StateGrammar -> String
faGraphvizPrinter name start cfg = faGraphvizPrinter name start =
prFAGraphviz $ mapStates (const "") fa prFAGraphviz . mapStates (const "") . cfgToFA start
where fa = cfgToFA start cfg
-- | Convert the grammar to a regular grammar and print it in BNF -- | Convert the grammar to a regular grammar and print it in BNF
regularPrinter :: CGrammar -> String regularPrinter :: StateGrammar -> String
regularPrinter = prCFRules . makeSimpleRegular regularPrinter = prCFRules . makeSimpleRegular
where where
prCFRules :: CFRules -> String prCFRules :: CFRules -> String
@@ -52,8 +51,8 @@ regularPrinter = prCFRules . makeSimpleRegular
showRhs = unwords . map (symbol id show) showRhs = unwords . map (symbol id show)
faCPrinter :: Ident -- ^ Grammar name faCPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String -> String -> StateGrammar -> String
faCPrinter name start cfg = fa2c $ cfgToFA start cfg faCPrinter name start = fa2c . cfgToFA start
fa2c :: DFA String -> String fa2c :: DFA String -> String
fa2c fa = undefined fa2c fa = undefined

17
src/GF/Speech/PrGSL.hs
View File

@@ -27,18 +27,19 @@ import GF.Conversion.Types
import GF.Infra.Print import GF.Infra.Print
import GF.Infra.Option import GF.Infra.Option
import GF.Probabilistic.Probabilistic (Probs) import GF.Probabilistic.Probabilistic (Probs)
import GF.Compile.ShellState (StateGrammar)
import Data.Char (toUpper,toLower) import Data.Char (toUpper,toLower)
gslPrinter :: Ident -- ^ Grammar name gslPrinter :: Ident -- ^ Grammar name
-> String -- ^ Start category -> String -- ^ Start category
-> Options -> Maybe Probs -> CGrammar -> String -> Options -> StateGrammar -> String
gslPrinter name start opts probs cfg = prGSL srg "" gslPrinter name start opts =
where srg = topDownFilter $ makeSimpleSRG name start opts probs $ rmPunctCFG cfg prGSL . topDownFilter . makeSimpleSRG name start opts
prGSL :: SRG -> ShowS prGSL :: SRG -> String
prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
= header . mainCat . unlinesS (map prRule rs) = (header . mainCat . unlinesS (map prRule rs)) ""
where where
header = showString ";GSL2.0" . nl header = showString ";GSL2.0" . nl
. comments ["Nuance speech recognition grammar for " ++ name, . comments ["Nuance speech recognition grammar for " ++ name,
@@ -59,12 +60,14 @@ firstToUpper :: String -> String
firstToUpper [] = [] firstToUpper [] = []
firstToUpper (x:xs) = toUpper x : xs firstToUpper (x:xs) = toUpper x : xs
{-
rmPunctCFG :: CGrammar -> CGrammar rmPunctCFG :: CGrammar -> CGrammar
rmPunctCFG g = [CFRule c (filter keepSymbol ss) n | CFRule c ss n <- g] rmPunctCFG g = [CFRule c (filter keepSymbol ss) n | CFRule c ss n <- g]
keepSymbol :: Symbol c Token -> Bool keepSymbol :: Symbol c Token -> Bool
keepSymbol (Tok t) = not (all isPunct (prt t)) keepSymbol (Tok t) = not (all isPunct (prt t))
keepSymbol _ = True keepSymbol _ = True
-}
-- Nuance does not like upper case characters in tokens -- Nuance does not like upper case characters in tokens
showToken :: Token -> String showToken :: Token -> String

11
src/GF/Speech/PrJSGF.hs
View File

@@ -30,6 +30,7 @@ import GF.Probabilistic.Probabilistic (Probs)
import GF.Speech.SISR import GF.Speech.SISR
import GF.Speech.SRG import GF.Speech.SRG
import GF.Speech.RegExp import GF.Speech.RegExp
import GF.Compile.ShellState (StateGrammar)
import Data.Char import Data.Char
import Data.List import Data.List
@@ -41,12 +42,12 @@ jsgfPrinter :: Ident -- ^ Grammar name
-> String -- ^ Start category -> String -- ^ Start category
-> Options -> Options
-> Maybe SISRFormat -> Maybe SISRFormat
-> Maybe Probs -> CGrammar -> String -> StateGrammar -> String
jsgfPrinter name start opts sisr probs cfg = show (prJSGF srg sisr) jsgfPrinter name start opts sisr =
where srg = makeSimpleSRG name start opts probs cfg show . prJSGF sisr . makeSimpleSRG name start opts
prJSGF :: SRG -> Maybe SISRFormat -> Doc prJSGF :: Maybe SISRFormat -> SRG -> Doc
prJSGF srg@(SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) sisr prJSGF sisr srg@(SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
= header $++$ mainCat $++$ vcat topCatRules $++$ foldr ($++$) empty (map prRule rs) = header $++$ mainCat $++$ vcat topCatRules $++$ foldr ($++$) empty (map prRule rs)
where where
header = text "#JSGF V1.0 UTF-8;" $$ header = text "#JSGF V1.0 UTF-8;" $$

5
src/GF/Speech/PrRegExp.hs
View File

@@ -14,8 +14,9 @@ import GF.Conversion.Types
import GF.Infra.Ident import GF.Infra.Ident
import GF.Speech.CFGToFiniteState import GF.Speech.CFGToFiniteState
import GF.Speech.RegExp import GF.Speech.RegExp
import GF.Compile.ShellState (StateGrammar)
regexpPrinter :: Ident -- ^ Grammar name regexpPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String -> String -> StateGrammar -> String
regexpPrinter name start cfg = prRE $ dfa2re $ cfgToFA start cfg regexpPrinter name start = prRE . dfa2re . cfgToFA start

39
src/GF/Speech/PrSLF.hs
View File

@@ -32,6 +32,7 @@ import GF.Speech.FiniteState
import GF.Speech.SRG import GF.Speech.SRG
import GF.Speech.TransformCFG import GF.Speech.TransformCFG
import qualified GF.Visualization.Graphviz as Dot import qualified GF.Visualization.Graphviz as Dot
import GF.Compile.ShellState (StateGrammar)
import Control.Monad import Control.Monad
import qualified Control.Monad.State as STM import qualified Control.Monad.State as STM
@@ -53,9 +54,9 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int }
type SLF_FA = FA State (Maybe (MFALabel String)) () type SLF_FA = FA State (Maybe (MFALabel String)) ()
mkFAs :: String -> CGrammar -> (SLF_FA, [(String,SLF_FA)]) mkFAs :: String -> StateGrammar -> (SLF_FA, [(String,SLF_FA)])
mkFAs start cfg = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs]) mkFAs start s = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
where MFA main subs = {- renameSubs $ -} cfgToMFA start cfg where MFA main subs = {- renameSubs $ -} cfgToMFA start s
slfStyleFA :: Eq a => DFA a -> FA State (Maybe a) () slfStyleFA :: Eq a => DFA a -> FA State (Maybe a) ()
slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing () slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing ()
@@ -75,9 +76,9 @@ renameSubs (MFA main subs) = MFA (renameLabels main) subs'
-- * SLF graphviz printing (without sub-networks) -- * SLF graphviz printing (without sub-networks)
-- --
slfGraphvizPrinter :: Ident -> String -> CGrammar -> String slfGraphvizPrinter :: Ident -> String -> StateGrammar -> String
slfGraphvizPrinter name start cfg slfGraphvizPrinter name start
= prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' start cfg = prFAGraphviz . gvFA . slfStyleFA . cfgToFA' start
where where
gvFA = mapStates (fromMaybe "") . mapTransitions (const "") gvFA = mapStates (fromMaybe "") . mapTransitions (const "")
@@ -86,9 +87,9 @@ slfGraphvizPrinter name start cfg
-- --
slfSubGraphvizPrinter :: Ident -- ^ Grammar name slfSubGraphvizPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String -> String -> StateGrammar -> String
slfSubGraphvizPrinter name start cfg = Dot.prGraphviz g slfSubGraphvizPrinter name start s = Dot.prGraphviz g
where (main, subs) = mkFAs start cfg where (main, subs) = mkFAs start s
g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..]
ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs
m = gvSLFFA Nothing main m = gvSLFFA Nothing main
@@ -113,9 +114,9 @@ gvSLFFA n fa =
-- * SLF printing (without sub-networks) -- * SLF printing (without sub-networks)
-- --
slfPrinter :: Ident -> String -> CGrammar -> String slfPrinter :: Ident -> String -> StateGrammar -> String
slfPrinter name start cfg slfPrinter name start
= prSLF (automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' start cfg) "" = prSLF . automatonToSLF mkSLFNode . slfStyleFA . cfgToFA' start
-- --
-- * SLF printing (with sub-networks) -- * SLF printing (with sub-networks)
@@ -123,10 +124,10 @@ slfPrinter name start cfg
-- | Make a network with subnetworks in SLF -- | Make a network with subnetworks in SLF
slfSubPrinter :: Ident -- ^ Grammar name slfSubPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String -> String -> StateGrammar -> String
slfSubPrinter name start cfg = prSLFs slfs "" slfSubPrinter name start s = prSLFs slfs
where where
(main,subs) = mkFAs start cfg (main,subs) = mkFAs start s
slfs = SLFs [(c, faToSLF fa) | (c,fa) <- subs] (faToSLF main) slfs = SLFs [(c, faToSLF fa) | (c,fa) <- subs] (faToSLF main)
faToSLF = automatonToSLF mfaNodeToSLFNode faToSLF = automatonToSLF mfaNodeToSLFNode
@@ -157,13 +158,13 @@ mkSLFSubLat i sub = SLFSubLat { nId = i, nLat = sub }
mkSLFEdge :: Int -> (Int,Int) -> SLFEdge mkSLFEdge :: Int -> (Int,Int) -> SLFEdge
mkSLFEdge i (f,t) = SLFEdge { eId = i, eStart = f, eEnd = t } mkSLFEdge i (f,t) = SLFEdge { eId = i, eStart = f, eEnd = t }
prSLFs :: SLFs -> ShowS prSLFs :: SLFs -> String
prSLFs (SLFs subs main) = unlinesS (map prSub subs ++ [prOneSLF main]) prSLFs (SLFs subs main) = unlinesS (map prSub subs ++ [prOneSLF main]) ""
where prSub (n,s) = showString "SUBLAT=" . shows n where prSub (n,s) = showString "SUBLAT=" . shows n
. nl . prOneSLF s . showString "." . nl . nl . prOneSLF s . showString "." . nl
prSLF :: SLF -> ShowS prSLF :: SLF -> String
prSLF slf = {- showString "VERSION=1.0" . nl . -} prOneSLF slf prSLF slf = prOneSLF slf ""
prOneSLF :: SLF -> ShowS prOneSLF :: SLF -> ShowS
prOneSLF (SLF { slfNodes = ns, slfEdges = es}) prOneSLF (SLF { slfNodes = ns, slfEdges = es})

24
src/GF/Speech/PrSRGS.hs
View File

@@ -27,6 +27,7 @@ import GF.Conversion.Types
import GF.Infra.Print import GF.Infra.Print
import GF.Infra.Option import GF.Infra.Option
import GF.Probabilistic.Probabilistic (Probs) import GF.Probabilistic.Probabilistic (Probs)
import GF.Compile.ShellState (StateGrammar)
import Data.Char (toUpper,toLower) import Data.Char (toUpper,toLower)
import Data.List import Data.List
@@ -39,15 +40,15 @@ srgsXmlPrinter :: Ident -- ^ Grammar name
-> String -- ^ Start category -> String -- ^ Start category
-> Options -> Options
-> Maybe SISRFormat -> Maybe SISRFormat
-> Maybe Probs -> Bool -- ^ Include probabilities
-> CGrammar -> String -> StateGrammar -> String
srgsXmlPrinter name start opts sisr probs cfg = prSrgsXml sisr srg "" srgsXmlPrinter name start opts sisr probs =
where srg = makeSRG name start opts probs cfg prSrgsXml sisr probs . makeSRG name start opts
prSrgsXml :: Maybe SISRFormat -> SRG -> ShowS prSrgsXml :: Maybe SISRFormat -> Bool -> SRG -> String
prSrgsXml sisr srg@(SRG{grammarName=name,startCat=start, prSrgsXml sisr probs srg@(SRG{grammarName=name,startCat=start,
origStartCat=origStart,grammarLanguage=l,rules=rs}) origStartCat=origStart,grammarLanguage=l,rules=rs})
= showsXMLDoc $ optimizeSRGS xmlGr = showXMLDoc (optimizeSRGS xmlGr)
where where
Just root = cfgCatToGFCat origStart Just root = cfgCatToGFCat origStart
xmlGr = grammar sisr (catFormId root) l $ xmlGr = grammar sisr (catFormId root) l $
@@ -60,7 +61,7 @@ prSrgsXml sisr srg@(SRG{grammarName=name,startCat=start,
++ concatMap ruleToXML rs ++ concatMap ruleToXML rs
ruleToXML (SRGRule cat origCat alts) = ruleToXML (SRGRule cat origCat alts) =
comments ["Category " ++ origCat] ++ [rule cat (prRhs alts)] comments ["Category " ++ origCat] ++ [rule cat (prRhs alts)]
prRhs rhss = [oneOf (map (mkProd sisr) rhss)] prRhs rhss = [oneOf (map (mkProd sisr probs) rhss)]
-- externally visible rules for each of the GF categories -- externally visible rules for each of the GF categories
topCatRules = [topRule tc [oneOf (map (it tc) cs)] | (tc,cs) <- srgTopCats srg] topCatRules = [topRule tc [oneOf (map (it tc) cs)] | (tc,cs) <- srgTopCats srg]
where it i c = Tag "item" [] [Tag "ruleref" [("uri","#" ++ c)] [], where it i c = Tag "item" [] [Tag "ruleref" [("uri","#" ++ c)] [],
@@ -86,10 +87,11 @@ mkItem sisr = f
f (RESymbol s) = symItem sisr s f (RESymbol s) = symItem sisr s
-} -}
mkProd :: Maybe SISRFormat -> SRGAlt -> XML mkProd :: Maybe SISRFormat -> Bool -> SRGAlt -> XML
mkProd sisr (SRGAlt mp n rhs) = Tag "item" w (ti ++ xs ++ tf) mkProd sisr probs (SRGAlt mp n rhs) = Tag "item" w (ti ++ xs ++ tf)
where xs = mkItem sisr n rhs where xs = mkItem sisr n rhs
w = maybe [] (\p -> [("weight", show p)]) mp w | probs = maybe [] (\p -> [("weight", show p)]) mp
| otherwise = []
ti = [tag sisr (profileInitSISR n)] ti = [tag sisr (profileInitSISR n)]
tf = [tag sisr (profileFinalSISR n)] tf = [tag sisr (profileFinalSISR n)]

31
src/GF/Speech/SRG.hs
View File

@@ -42,6 +42,7 @@ import GF.Speech.FiniteState
import GF.Speech.RegExp import GF.Speech.RegExp
import GF.Infra.Option import GF.Infra.Option
import GF.Probabilistic.Probabilistic (Probs) import GF.Probabilistic.Probabilistic (Probs)
import GF.Compile.ShellState (StateGrammar, stateProbs)
import Data.List import Data.List
import Data.Maybe (fromMaybe, maybeToList) import Data.Maybe (fromMaybe, maybeToList)
@@ -83,30 +84,30 @@ type CatNames = Map String String
makeSimpleSRG :: Ident -- ^ Grammar name makeSimpleSRG :: Ident -- ^ Grammar name
-> String -- ^ Start category -> String -- ^ Start category
-> Options -- ^ Grammar options -> Options -- ^ Grammar options
-> Maybe Probs -- ^ Probabilities -> StateGrammar
-> CGrammar -- ^ A context-free grammar
-> SRG -> SRG
makeSimpleSRG i origStart opts probs = makeSimpleSRG i origStart opts s =
makeSRG_ i origStart opts probs makeSRG_ i origStart opts probs $ preprocess $ cfgToCFRules s
. removeLeftRecursion origStart . removeIdenticalRules where preprocess = removeLeftRecursion origStart . removeIdenticalRules
. removeEmptyCats . removeCycles . removeEmptyCats . removeCycles
. cfgToCFRules probs = stateProbs s
-- | Create a SRG preserving the names, profiles and probabilities of the -- | Create a SRG preserving the names, profiles and probabilities of the
-- input grammar. The returned grammar may be left-recursive. -- input grammar. The returned grammar may be left-recursive.
makeSRG :: Ident -- ^ Grammar name makeSRG :: Ident -- ^ Grammar name
-> String -- ^ Start category -> String -- ^ Start category
-> Options -- ^ Grammar options -> Options -- ^ Grammar options
-> Maybe Probs -- ^ Probabilities -> StateGrammar
-> CGrammar -- ^ A context-free grammar
-> SRG -> SRG
makeSRG i origStart opts probs = makeSRG i origStart opts s =
makeSRG_ i origStart opts probs . removeEmptyCats . cfgToCFRules makeSRG_ i origStart opts probs $ preprocess $ cfgToCFRules s
where preprocess = removeEmptyCats
probs = stateProbs s
makeSRG_ :: Ident -- ^ Grammar name makeSRG_ :: Ident -- ^ Grammar name
-> String -- ^ Start category -> String -- ^ Start category
-> Options -- ^ Grammar options -> Options -- ^ Grammar options
-> Maybe Probs -- ^ Probabilities -> Probs -- ^ Probabilities
-> CFRules -- ^ A context-free grammar -> CFRules -- ^ A context-free grammar
-> SRG -> SRG
makeSRG_ i origStart opts probs gr = makeSRG_ i origStart opts probs gr =
@@ -123,7 +124,7 @@ makeSRG_ i origStart opts probs gr =
rs = map (cfgRulesToSRGRule names probs) cfgRules rs = map (cfgRulesToSRGRule names probs) cfgRules
-- FIXME: merge alternatives with same rhs and profile but different probabilities -- FIXME: merge alternatives with same rhs and profile but different probabilities
cfgRulesToSRGRule :: Map String String -> Maybe Probs -> [CFRule_] -> SRGRule cfgRulesToSRGRule :: Map String String -> Probs -> [CFRule_] -> SRGRule
cfgRulesToSRGRule names probs rs@(r:_) = SRGRule cat origCat rhs cfgRulesToSRGRule names probs rs@(r:_) = SRGRule cat origCat rhs
where where
origCat = lhsCat r origCat = lhsCat r
@@ -137,8 +138,8 @@ cfgRulesToSRGRule names probs rs@(r:_) = SRGRule cat origCat rhs
mkSRGSymbols i (Tok t:ss) = Tok t : mkSRGSymbols i ss mkSRGSymbols i (Tok t:ss) = Tok t : mkSRGSymbols i ss
renameCat = lookupFM_ names renameCat = lookupFM_ names
ruleProb :: Maybe Probs -> CFRule_ -> Maybe Double ruleProb :: Probs -> CFRule_ -> Maybe Double
ruleProb mp r = mp >>= \probs -> lookupProb probs (ruleFun r) ruleProb probs r = lookupProb probs (ruleFun r)
-- FIXME: move to GF.Probabilistic.Probabilistic? -- FIXME: move to GF.Probabilistic.Probabilistic?
lookupProb :: Probs -> Ident -> Maybe Double lookupProb :: Probs -> Ident -> Maybe Double

8
src/GF/Speech/TransformCFG.hs
View File

@@ -32,6 +32,7 @@ import GF.Infra.Ident
import GF.Infra.Option import GF.Infra.Option
import GF.Infra.Print import GF.Infra.Print
import GF.Speech.Relation import GF.Speech.Relation
import GF.Compile.ShellState (StateGrammar, stateCFG)
import Control.Monad import Control.Monad
import Control.Monad.State (State, get, put, evalState) import Control.Monad.State (State, get, put, evalState)
@@ -63,11 +64,12 @@ type CFSymbol_ = Symbol Cat_ Token
type CFRules = [(Cat_,[CFRule_])] type CFRules = [(Cat_,[CFRule_])]
cfgToCFRules :: CGrammar -> CFRules cfgToCFRules :: StateGrammar -> CFRules
cfgToCFRules cfg = cfgToCFRules s =
groupProds [CFRule (catToString c) (map symb r) (nameToTerm n) groupProds [CFRule (catToString c) (map symb r) (nameToTerm n)
| CFRule c r n <- cfg] | CFRule c r n <- cfg]
where symb = mapSymbol catToString id where cfg = stateCFG s
symb = mapSymbol catToString id
catToString = prt catToString = prt
nameToTerm (Name f prs) = CFObj f (map profileToTerm prs) nameToTerm (Name f prs) = CFObj f (map profileToTerm prs)
profileToTerm (Unify []) = CFMeta profileToTerm (Unify []) = CFMeta

29
src/GF/UseGrammar/Custom.hs
View File

@@ -250,50 +250,49 @@ customGrammarPrinter =
,(strCI "srg", \_ -> prSRG . stateCF) ,(strCI "srg", \_ -> prSRG . stateCF)
,(strCI "gsl", \opts s -> let name = cncId s ,(strCI "gsl", \opts s -> let name = cncId s
start = getStartCatCF opts s start = getStartCatCF opts s
in gslPrinter name start opts Nothing $ stateCFG s) in gslPrinter name start opts s)
,(strCI "jsgf", \opts s -> let name = cncId s ,(strCI "jsgf", \opts s -> let name = cncId s
start = getStartCatCF opts s start = getStartCatCF opts s
in jsgfPrinter name start opts Nothing Nothing $ stateCFG s) in jsgfPrinter name start opts Nothing s)
,(strCI "jsgf_sisr_old", ,(strCI "jsgf_sisr_old",
\opts s -> let name = cncId s \opts s -> let name = cncId s
start = getStartCatCF opts s start = getStartCatCF opts s
in jsgfPrinter name start opts (Just SISR.SISROld) Nothing $ stateCFG s) in jsgfPrinter name start opts (Just SISR.SISROld) s)
,(strCI "srgs_xml", \opts s -> let name = cncId s ,(strCI "srgs_xml", \opts s -> let name = cncId s
start = getStartCatCF opts s start = getStartCatCF opts s
in SRGS.srgsXmlPrinter name start opts Nothing Nothing $ stateCFG s) in SRGS.srgsXmlPrinter name start opts Nothing False s)
,(strCI "srgs_xml_prob", ,(strCI "srgs_xml_prob",
\opts s -> let name = cncId s \opts s -> let name = cncId s
probs = stateProbs s
start = getStartCatCF opts s start = getStartCatCF opts s
in SRGS.srgsXmlPrinter name start opts Nothing (Just probs) $ stateCFG s) in SRGS.srgsXmlPrinter name start opts Nothing True s)
,(strCI "srgs_xml_sisr_old", ,(strCI "srgs_xml_sisr_old",
\opts s -> let name = cncId s \opts s -> let name = cncId s
start = getStartCatCF opts s start = getStartCatCF opts s
in SRGS.srgsXmlPrinter name start opts (Just SISR.SISROld) Nothing $ stateCFG s) in SRGS.srgsXmlPrinter name start opts (Just SISR.SISROld) False s)
,(strCI "vxml", \opts s -> let start = cfCat2Ident (startCatStateOpts opts s) ,(strCI "vxml", \opts s -> let start = cfCat2Ident (startCatStateOpts opts s)
in grammar2vxml start s) in grammar2vxml start s)
,(strCI "slf", \opts s -> let start = getStartCatCF opts s ,(strCI "slf", \opts s -> let start = getStartCatCF opts s
name = cncId s name = cncId s
in slfPrinter name start $ stateCFG s) in slfPrinter name start s)
,(strCI "slf_graphviz", \opts s -> let start = getStartCatCF opts s ,(strCI "slf_graphviz", \opts s -> let start = getStartCatCF opts s
name = cncId s name = cncId s
in slfGraphvizPrinter name start $ stateCFG s) in slfGraphvizPrinter name start s)
,(strCI "slf_sub", \opts s -> let start = getStartCatCF opts s ,(strCI "slf_sub", \opts s -> let start = getStartCatCF opts s
name = cncId s name = cncId s
in slfSubPrinter name start $ stateCFG s) in slfSubPrinter name start s)
,(strCI "slf_sub_graphviz", \opts s -> let start = getStartCatCF opts s ,(strCI "slf_sub_graphviz", \opts s -> let start = getStartCatCF opts s
name = cncId s name = cncId s
in slfSubGraphvizPrinter name start $ stateCFG s) in slfSubGraphvizPrinter name start s)
,(strCI "fa_graphviz", \opts s -> let start = getStartCatCF opts s ,(strCI "fa_graphviz", \opts s -> let start = getStartCatCF opts s
name = cncId s name = cncId s
in faGraphvizPrinter name start $ stateCFG s) in faGraphvizPrinter name start s)
,(strCI "fa_c", \opts s -> let start = getStartCatCF opts s ,(strCI "fa_c", \opts s -> let start = getStartCatCF opts s
name = cncId s name = cncId s
in faCPrinter name start $ stateCFG s) in faCPrinter name start s)
,(strCI "regexp", \opts s -> let start = getStartCatCF opts s ,(strCI "regexp", \opts s -> let start = getStartCatCF opts s
name = cncId s name = cncId s
in regexpPrinter name start $ stateCFG s) in regexpPrinter name start s)
,(strCI "regular", \_ -> regularPrinter . stateCFG) ,(strCI "regular", \_ -> regularPrinter)
,(strCI "plbnf", \_ -> prLBNF True) ,(strCI "plbnf", \_ -> prLBNF True)
,(strCI "lbnf", \_ -> prLBNF False) ,(strCI "lbnf", \_ -> prLBNF False)
,(strCI "bnf", \_ -> prBNF False) ,(strCI "bnf", \_ -> prBNF False)