GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-15 15:59:32 -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.
-----------------------------------------------------------------------------
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
@@ -20,6 +20,9 @@ type Attr = (String,String)
comments :: [String] -> [XML]
comments = map Comment
showXMLDoc :: XML -> String
showXMLDoc xml = showsXMLDoc xml ""
showsXMLDoc :: XML -> ShowS
showsXMLDoc xml = showString header . showsXML xml
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.Conversion.Types
import GF.Infra.Ident (Ident)
import GF.Compile.ShellState (StateGrammar)
import GF.Speech.FiniteState
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
makeSimpleRegular :: CGrammar -> CFRules
makeSimpleRegular :: StateGrammar -> CFRules
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
--
cfgToMFA :: String -> CGrammar -> MFA String
cfgToMFA :: String -> StateGrammar -> MFA String
cfgToMFA start g = buildMFA start g
-- | Build a DFA by building and expanding an MFA
cfgToFA' :: String -> CGrammar -> DFA String
cfgToFA' start g = mfaToDFA $ cfgToMFA start g
cfgToFA' :: String -> StateGrammar -> DFA String
cfgToFA' start = mfaToDFA . cfgToMFA start
buildMFA :: Cat_ -- ^ Start category
-> CGrammar -> MFA String
-> StateGrammar -> MFA String
buildMFA start g = sortSubLats $ removeUnusedSubLats mfa
where startFA = let (fa,s,f) = newFA_
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.SRG
import GF.Speech.TransformCFG
import GF.Compile.ShellState (StateGrammar)
import Data.Char (toUpper,toLower)
import Data.List
@@ -36,14 +37,12 @@ import Data.Maybe (fromMaybe)
faGraphvizPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String
faGraphvizPrinter name start cfg =
prFAGraphviz $ mapStates (const "") fa
where fa = cfgToFA start cfg
-> String -> StateGrammar -> String
faGraphvizPrinter name start =
prFAGraphviz . mapStates (const "") . cfgToFA start
-- | Convert the grammar to a regular grammar and print it in BNF
regularPrinter :: CGrammar -> String
regularPrinter :: StateGrammar -> String
regularPrinter = prCFRules . makeSimpleRegular
where
prCFRules :: CFRules -> String
@@ -52,8 +51,8 @@ regularPrinter = prCFRules . makeSimpleRegular
showRhs = unwords . map (symbol id show)
faCPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String
faCPrinter name start cfg = fa2c $ cfgToFA start cfg
-> String -> StateGrammar -> String
faCPrinter name start = fa2c . cfgToFA start
fa2c :: DFA String -> String
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.Option
import GF.Probabilistic.Probabilistic (Probs)
import GF.Compile.ShellState (StateGrammar)
import Data.Char (toUpper,toLower)
gslPrinter :: Ident -- ^ Grammar name
-> String -- ^ Start category
-> Options -> Maybe Probs -> CGrammar -> String
gslPrinter name start opts probs cfg = prGSL srg ""
where srg = topDownFilter $ makeSimpleSRG name start opts probs $ rmPunctCFG cfg
gslPrinter :: Ident -- ^ Grammar name
-> String -- ^ Start category
-> Options -> StateGrammar -> String
gslPrinter name start opts =
prGSL . topDownFilter . makeSimpleSRG name start opts
prGSL :: SRG -> ShowS
prGSL :: SRG -> String
prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
= header . mainCat . unlinesS (map prRule rs)
= (header . mainCat . unlinesS (map prRule rs)) ""
where
header = showString ";GSL2.0" . nl
. comments ["Nuance speech recognition grammar for " ++ name,
@@ -59,12 +60,14 @@ firstToUpper :: String -> String
firstToUpper [] = []
firstToUpper (x:xs) = toUpper x : xs
{-
rmPunctCFG :: CGrammar -> CGrammar
rmPunctCFG g = [CFRule c (filter keepSymbol ss) n | CFRule c ss n <- g]
keepSymbol :: Symbol c Token -> Bool
keepSymbol (Tok t) = not (all isPunct (prt t))
keepSymbol _ = True
-}
-- Nuance does not like upper case characters in tokens
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.SRG
import GF.Speech.RegExp
import GF.Compile.ShellState (StateGrammar)
import Data.Char
import Data.List
@@ -41,12 +42,12 @@ jsgfPrinter :: Ident -- ^ Grammar name
-> String -- ^ Start category
-> Options
-> Maybe SISRFormat
-> Maybe Probs -> CGrammar -> String
jsgfPrinter name start opts sisr probs cfg = show (prJSGF srg sisr)
where srg = makeSimpleSRG name start opts probs cfg
-> StateGrammar -> String
jsgfPrinter name start opts sisr =
show . prJSGF sisr . makeSimpleSRG name start opts
prJSGF :: SRG -> Maybe SISRFormat -> Doc
prJSGF srg@(SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) sisr
prJSGF :: Maybe SISRFormat -> SRG -> Doc
prJSGF sisr srg@(SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
= header $++$ mainCat $++$ vcat topCatRules $++$ foldr ($++$) empty (map prRule rs)
where
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.Speech.CFGToFiniteState
import GF.Speech.RegExp
import GF.Compile.ShellState (StateGrammar)
regexpPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String
regexpPrinter name start cfg = prRE $ dfa2re $ cfgToFA start cfg
-> String -> StateGrammar -> String
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.TransformCFG
import qualified GF.Visualization.Graphviz as Dot
import GF.Compile.ShellState (StateGrammar)
import Control.Monad
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)) ()
mkFAs :: String -> CGrammar -> (SLF_FA, [(String,SLF_FA)])
mkFAs start cfg = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
where MFA main subs = {- renameSubs $ -} cfgToMFA start cfg
mkFAs :: String -> StateGrammar -> (SLF_FA, [(String,SLF_FA)])
mkFAs start s = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
where MFA main subs = {- renameSubs $ -} cfgToMFA start s
slfStyleFA :: Eq a => DFA a -> FA State (Maybe a) ()
slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing ()
@@ -75,9 +76,9 @@ renameSubs (MFA main subs) = MFA (renameLabels main) subs'
-- * SLF graphviz printing (without sub-networks)
--
slfGraphvizPrinter :: Ident -> String -> CGrammar -> String
slfGraphvizPrinter name start cfg
= prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' start cfg
slfGraphvizPrinter :: Ident -> String -> StateGrammar -> String
slfGraphvizPrinter name start
= prFAGraphviz . gvFA . slfStyleFA . cfgToFA' start
where
gvFA = mapStates (fromMaybe "") . mapTransitions (const "")
@@ -86,9 +87,9 @@ slfGraphvizPrinter name start cfg
--
slfSubGraphvizPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String
slfSubGraphvizPrinter name start cfg = Dot.prGraphviz g
where (main, subs) = mkFAs start cfg
-> String -> StateGrammar -> String
slfSubGraphvizPrinter name start s = Dot.prGraphviz g
where (main, subs) = mkFAs start s
g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..]
ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs
m = gvSLFFA Nothing main
@@ -113,9 +114,9 @@ gvSLFFA n fa =
-- * SLF printing (without sub-networks)
--
slfPrinter :: Ident -> String -> CGrammar -> String
slfPrinter name start cfg
= prSLF (automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' start cfg) ""
slfPrinter :: Ident -> String -> StateGrammar -> String
slfPrinter name start
= prSLF . automatonToSLF mkSLFNode . slfStyleFA . cfgToFA' start
--
-- * SLF printing (with sub-networks)
@@ -123,10 +124,10 @@ slfPrinter name start cfg
-- | Make a network with subnetworks in SLF
slfSubPrinter :: Ident -- ^ Grammar name
-> String -> CGrammar -> String
slfSubPrinter name start cfg = prSLFs slfs ""
-> String -> StateGrammar -> String
slfSubPrinter name start s = prSLFs slfs
where
(main,subs) = mkFAs start cfg
(main,subs) = mkFAs start s
slfs = SLFs [(c, faToSLF fa) | (c,fa) <- subs] (faToSLF main)
faToSLF = automatonToSLF mfaNodeToSLFNode
@@ -157,13 +158,13 @@ mkSLFSubLat i sub = SLFSubLat { nId = i, nLat = sub }
mkSLFEdge :: Int -> (Int,Int) -> SLFEdge
mkSLFEdge i (f,t) = SLFEdge { eId = i, eStart = f, eEnd = t }
prSLFs :: SLFs -> ShowS
prSLFs (SLFs subs main) = unlinesS (map prSub subs ++ [prOneSLF main])
prSLFs :: SLFs -> String
prSLFs (SLFs subs main) = unlinesS (map prSub subs ++ [prOneSLF main]) ""
where prSub (n,s) = showString "SUBLAT=" . shows n
. nl . prOneSLF s . showString "." . nl
prSLF :: SLF -> ShowS
prSLF slf = {- showString "VERSION=1.0" . nl . -} prOneSLF slf
prSLF :: SLF -> String
prSLF slf = prOneSLF slf ""
prOneSLF :: SLF -> ShowS
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.Option
import GF.Probabilistic.Probabilistic (Probs)
import GF.Compile.ShellState (StateGrammar)
import Data.Char (toUpper,toLower)
import Data.List
@@ -39,15 +40,15 @@ srgsXmlPrinter :: Ident -- ^ Grammar name
-> String -- ^ Start category
-> Options
-> Maybe SISRFormat
-> Maybe Probs
-> CGrammar -> String
srgsXmlPrinter name start opts sisr probs cfg = prSrgsXml sisr srg ""
where srg = makeSRG name start opts probs cfg
-> Bool -- ^ Include probabilities
-> StateGrammar -> String
srgsXmlPrinter name start opts sisr probs =
prSrgsXml sisr probs . makeSRG name start opts
prSrgsXml :: Maybe SISRFormat -> SRG -> ShowS
prSrgsXml sisr srg@(SRG{grammarName=name,startCat=start,
prSrgsXml :: Maybe SISRFormat -> Bool -> SRG -> String
prSrgsXml sisr probs srg@(SRG{grammarName=name,startCat=start,
origStartCat=origStart,grammarLanguage=l,rules=rs})
= showsXMLDoc $ optimizeSRGS xmlGr
= showXMLDoc (optimizeSRGS xmlGr)
where
Just root = cfgCatToGFCat origStart
xmlGr = grammar sisr (catFormId root) l $
@@ -60,7 +61,7 @@ prSrgsXml sisr srg@(SRG{grammarName=name,startCat=start,
++ concatMap ruleToXML rs
ruleToXML (SRGRule cat origCat 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
topCatRules = [topRule tc [oneOf (map (it tc) cs)] | (tc,cs) <- srgTopCats srg]
where it i c = Tag "item" [] [Tag "ruleref" [("uri","#" ++ c)] [],
@@ -86,10 +87,11 @@ mkItem sisr = f
f (RESymbol s) = symItem sisr s
-}
mkProd :: Maybe SISRFormat -> SRGAlt -> XML
mkProd sisr (SRGAlt mp n rhs) = Tag "item" w (ti ++ xs ++ tf)
mkProd :: Maybe SISRFormat -> Bool -> SRGAlt -> XML
mkProd sisr probs (SRGAlt mp n rhs) = Tag "item" w (ti ++ xs ++ tf)
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)]
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.Infra.Option
import GF.Probabilistic.Probabilistic (Probs)
import GF.Compile.ShellState (StateGrammar, stateProbs)
import Data.List
import Data.Maybe (fromMaybe, maybeToList)
@@ -83,30 +84,30 @@ type CatNames = Map String String
makeSimpleSRG :: Ident -- ^ Grammar name
-> String -- ^ Start category
-> Options -- ^ Grammar options
-> Maybe Probs -- ^ Probabilities
-> CGrammar -- ^ A context-free grammar
-> StateGrammar
-> SRG
makeSimpleSRG i origStart opts probs =
makeSRG_ i origStart opts probs
. removeLeftRecursion origStart . removeIdenticalRules
. removeEmptyCats . removeCycles
. cfgToCFRules
makeSimpleSRG i origStart opts s =
makeSRG_ i origStart opts probs $ preprocess $ cfgToCFRules s
where preprocess = removeLeftRecursion origStart . removeIdenticalRules
. removeEmptyCats . removeCycles
probs = stateProbs s
-- | Create a SRG preserving the names, profiles and probabilities of the
-- input grammar. The returned grammar may be left-recursive.
makeSRG :: Ident -- ^ Grammar name
-> String -- ^ Start category
-> Options -- ^ Grammar options
-> Maybe Probs -- ^ Probabilities
-> CGrammar -- ^ A context-free grammar
-> StateGrammar
-> SRG
makeSRG i origStart opts probs =
makeSRG_ i origStart opts probs . removeEmptyCats . cfgToCFRules
makeSRG i origStart opts s =
makeSRG_ i origStart opts probs $ preprocess $ cfgToCFRules s
where preprocess = removeEmptyCats
probs = stateProbs s
makeSRG_ :: Ident -- ^ Grammar name
-> String -- ^ Start category
-> Options -- ^ Grammar options
-> Maybe Probs -- ^ Probabilities
-> Probs -- ^ Probabilities
-> CFRules -- ^ A context-free grammar
-> SRG
makeSRG_ i origStart opts probs gr =
@@ -123,7 +124,7 @@ makeSRG_ i origStart opts probs gr =
rs = map (cfgRulesToSRGRule names probs) cfgRules
-- 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
where
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
renameCat = lookupFM_ names
ruleProb :: Maybe Probs -> CFRule_ -> Maybe Double
ruleProb mp r = mp >>= \probs -> lookupProb probs (ruleFun r)
ruleProb :: Probs -> CFRule_ -> Maybe Double
ruleProb probs r = lookupProb probs (ruleFun r)
-- FIXME: move to GF.Probabilistic.Probabilistic?
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.Print
import GF.Speech.Relation
import GF.Compile.ShellState (StateGrammar, stateCFG)
import Control.Monad
import Control.Monad.State (State, get, put, evalState)
@@ -63,11 +64,12 @@ type CFSymbol_ = Symbol Cat_ Token
type CFRules = [(Cat_,[CFRule_])]
cfgToCFRules :: CGrammar -> CFRules
cfgToCFRules cfg =
cfgToCFRules :: StateGrammar -> CFRules
cfgToCFRules s =
groupProds [CFRule (catToString c) (map symb r) (nameToTerm n)
| CFRule c r n <- cfg]
where symb = mapSymbol catToString id
where cfg = stateCFG s
symb = mapSymbol catToString id
catToString = prt
nameToTerm (Name f prs) = CFObj f (map profileToTerm prs)
profileToTerm (Unify []) = CFMeta

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

@@ -250,50 +250,49 @@ customGrammarPrinter =
,(strCI "srg", \_ -> prSRG . stateCF)
,(strCI "gsl", \opts s -> let name = cncId 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
start = getStartCatCF opts s
in jsgfPrinter name start opts Nothing Nothing $ stateCFG s)
in jsgfPrinter name start opts Nothing s)
,(strCI "jsgf_sisr_old",
\opts s -> let name = cncId 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
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",
\opts s -> let name = cncId s
probs = stateProbs 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",
\opts s -> let name = cncId 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)
in grammar2vxml start s)
,(strCI "slf", \opts s -> let start = getStartCatCF opts 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
name = cncId s
in slfGraphvizPrinter name start $ stateCFG s)
in slfGraphvizPrinter name start s)
,(strCI "slf_sub", \opts s -> let start = getStartCatCF opts 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
name = cncId s
in slfSubGraphvizPrinter name start $ stateCFG s)
in slfSubGraphvizPrinter name start s)
,(strCI "fa_graphviz", \opts s -> let start = getStartCatCF opts 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
name = cncId s
in faCPrinter name start $ stateCFG s)
in faCPrinter name start s)
,(strCI "regexp", \opts s -> let start = getStartCatCF opts s
name = cncId s
in regexpPrinter name start $ stateCFG s)
,(strCI "regular", \_ -> regularPrinter . stateCFG)
in regexpPrinter name start s)
,(strCI "regular", \_ -> regularPrinter)
,(strCI "plbnf", \_ -> prLBNF True)
,(strCI "lbnf", \_ -> prLBNF False)
,(strCI "bnf", \_ -> prBNF False)