msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

completely phrase based parser and support for pre {} in PMCFG

Browse Source
This commit is contained in:
krasimir
2009-06-16 11:56:08 +00:00
parent b442cde3bd
commit 8bc8929c59
12 changed files with 147 additions and 68 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/GF/Compile/GFCCtoJS.hs
View File

@@ -129,7 +129,7 @@ lins2js p ls = JS.EArray [JS.EArray [sym2js s | s <- Array.elems (sequences p Ar
sym2js :: FSymbol -> JS.Expr
sym2js (FSymCat n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
sym2js (FSymLit n l) = new "ArgProj" [JS.EInt n, JS.EInt l]
sym2js (FSymTok (KS t)) = new "Terminal" [JS.EStr t]
sym2js (FSymKS [t]) = new "Terminal" [JS.EStr t]
new :: String -> [JS.Expr] -> JS.Expr
new f xs = JS.ENew (JS.Ident f) xs

5
src/GF/Compile/GenerateFCFG.hs
View File

@@ -158,7 +158,10 @@ translateLin idxArgs ((lbl,syms) : lins) grammarEnv lbl'
| lbl' == lbl = addFSeq grammarEnv (lbl,map instSym syms)
| otherwise = translateLin idxArgs lins grammarEnv lbl'
where
instSym = either (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) FSymTok
instSym = either (\(lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs)
(\t -> case t of
KS s -> FSymKS [s]
KP strs vars -> FSymKP strs vars)
instCat lbl nr xnr nr' ((idx,xargs):idxArgs)
| nr == idx = let (fcat, PFCat _ rcs _) = xargs !! xnr
in FSymCat (nr'+xnr) (index lbl rcs 0)

21
src/GF/Compile/GeneratePMCFG.hs
View File

@@ -213,10 +213,22 @@ addSequences' env (Return v) = let (env1,v1) = addSequences env v
addSequences :: GrammarEnv -> Value [FSymbol] -> (GrammarEnv, Value SeqId)
addSequences env (Rec vs) = let (env1,vs1) = List.mapAccumL addSequences' env vs
in (env1,Rec vs1)
addSequences env (Str lin) = let (env1,seqid) = addFSeq env lin
addSequences env (Str lin) = let (env1,seqid) = addFSeq env (optimizeLin lin)
in (env1,Str seqid)
addSequences env (Con i) = (env,Con i)
optimizeLin [] = []
optimizeLin lin@(FSymKS _ : _) =
let (ts,lin') = getRest lin
in FSymKS ts : optimizeLin lin'
where
getRest (FSymKS ts : lin) = let (ts1,lin') = getRest lin
in (ts++ts1,lin')
getRest lin = ([],lin)
optimizeLin (sym : lin) = sym : optimizeLin lin
convertTerm :: TermMap -> FPath -> Term -> Term -> CnvMonad (Value [FSymbol])
convertTerm cnc_defs sel ctype (V nr) = convertArg ctype nr (reverse sel)
convertTerm cnc_defs sel ctype (C nr) = convertCon ctype nr (reverse sel)
@@ -227,11 +239,8 @@ convertTerm cnc_defs sel ctype (FV vars) = do term <- variants vars
convertTerm cnc_defs sel ctype term
convertTerm cnc_defs sel ctype (S ts) = do vs <- mapM (convertTerm cnc_defs sel ctype) ts
return (Str (concat [s | Str s <- vs]))
--convertTerm cnc_defs sel ctype (K t) = return (Str [FSymTok t])
convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [FSymTok (KS t)])
convertTerm cnc_defs sel ctype (K (KP strs vars)) =
do toks <- variants (strs:[strs' | Alt strs' _ <- vars])
return (Str (map (FSymTok . KS) toks))
convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [FSymKS [t]])
convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [FSymKP s v])
convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of
Just term -> convertTerm cnc_defs sel ctype term
Nothing -> error ("unknown id " ++ prCId id)

55
src/GF/Data/TrieMap.hs Normal file
View File

@@ -0,0 +1,55 @@
module GF.Data.TrieMap
( TrieMap
, empty
, singleton
, lookup
, null
, decompose
, insertWith
, unionWith
) where
import Prelude hiding (lookup, null)
import qualified Data.Map as Map
data TrieMap k v = Tr (Maybe v) (Map.Map k (TrieMap k v))
empty = Tr Nothing Map.empty
singleton :: [k] -> a -> TrieMap k a
singleton [] v = Tr (Just v) Map.empty
singleton (k:ks) v = Tr Nothing (Map.singleton k (singleton ks v))
lookup :: Ord k => [k] -> TrieMap k a -> Maybe a
lookup [] (Tr mb_v m) = mb_v
lookup (k:ks) (Tr mb_v m) = Map.lookup k m >>= lookup ks
null :: TrieMap k v -> Bool
null (Tr Nothing m) = Map.null m
null _ = False
decompose :: TrieMap k v -> (Maybe v, Map.Map k (TrieMap k v))
decompose (Tr mb_v m) = (mb_v,m)
insertWith :: Ord k => (v -> v -> v) -> [k] -> v -> TrieMap k v -> TrieMap k v
insertWith f [] v0 (Tr mb_v m) = case mb_v of
Just v -> Tr (Just (f v0 v)) m
Nothing -> Tr (Just v0 ) m
insertWith f (k:ks) v0 (Tr mb_v m) = case Map.lookup k m of
Nothing -> Tr mb_v (Map.insert k (singleton ks v0) m)
Just tr -> Tr mb_v (Map.insert k (insertWith f ks v0 tr) m)
unionWith :: Ord k => (v -> v -> v) -> TrieMap k v -> TrieMap k v -> TrieMap k v
unionWith f (Tr mb_v1 m1) (Tr mb_v2 m2) =
let mb_v = case (mb_v1,mb_v2) of
(Nothing,Nothing) -> Nothing
(Just v ,Nothing) -> Just v
(Nothing,Just v ) -> Just v
(Just v1,Just v2) -> Just (f v1 v2)
m = Map.unionWith (unionWith f) m1 m2
in Tr mb_v m

10
src/GF/Speech/PGFToCFG.hs
View File

@@ -82,17 +82,17 @@ pgfToCFG pgf lang = mkCFG (prCId (lookStartCat pgf)) extCats (startRules ++ conc
FFun f ps rhs = functions pinfo ! funid
mkRhs :: Array FPointPos FSymbol -> [CFSymbol]
mkRhs = map fsymbolToSymbol . Array.elems
mkRhs = concatMap fsymbolToSymbol . Array.elems
containsLiterals :: Array FPointPos FSymbol -> Bool
containsLiterals row = any isLiteralFCat [args!!n | FSymCat n _ <- Array.elems row] ||
not (null [n | FSymLit n _ <- Array.elems row]) -- only this is needed for PMCFG.
-- The first line is for backward compat.
fsymbolToSymbol :: FSymbol -> CFSymbol
fsymbolToSymbol (FSymCat n l) = NonTerminal (fcatToCat (args!!n) l)
fsymbolToSymbol (FSymLit n l) = NonTerminal (fcatToCat (args!!n) l)
fsymbolToSymbol (FSymTok (KS t)) = Terminal t
fsymbolToSymbol :: FSymbol -> [CFSymbol]
fsymbolToSymbol (FSymCat n l) = [NonTerminal (fcatToCat (args!!n) l)]
fsymbolToSymbol (FSymLit n l) = [NonTerminal (fcatToCat (args!!n) l)]
fsymbolToSymbol (FSymKS ts) = map Terminal ts
fixProfile :: Array FPointPos FSymbol -> Profile -> Profile
fixProfile row = concatMap positions