From fa6ba9a5318640778040e86268e9003216f3636e Mon Sep 17 00:00:00 2001 From: peb Date: Tue, 12 Apr 2005 09:49:44 +0000 Subject: "Committed_by_peb" --- src/GF/Conversion/SimpleToMCFG/Coercions.hs | 6 +++--- src/GF/Conversion/SimpleToMCFG/Nondet.hs | 30 ++++++++++++++--------------- src/GF/Conversion/SimpleToMCFG/Strict.hs | 24 +++++++++++------------ 3 files changed, 30 insertions(+), 30 deletions(-) (limited to 'src/GF/Conversion/SimpleToMCFG') diff --git a/src/GF/Conversion/SimpleToMCFG/Coercions.hs b/src/GF/Conversion/SimpleToMCFG/Coercions.hs index c1dc5b07c..a57953061 100644 --- a/src/GF/Conversion/SimpleToMCFG/Coercions.hs +++ b/src/GF/Conversion/SimpleToMCFG/Coercions.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:49 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Adding coercion functions to a MCFG if necessary. ----------------------------------------------------------------------------- @@ -45,7 +45,7 @@ addCoercions rules = coercions ++ rules combineCoercions [] _ = [] combineCoercions _ [] = [] combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) - = case compare (mcat2cat $ fst $ head heads) (mcat2cat $ head args) of + = case compare (mcat2scat $ fst $ head heads) (mcat2scat $ head args) of LT -> combineCoercions allHeads allArgs' GT -> combineCoercions allHeads' allArgs EQ -> makeCoercion heads args : combineCoercions allHeads allArgs diff --git a/src/GF/Conversion/SimpleToMCFG/Nondet.hs b/src/GF/Conversion/SimpleToMCFG/Nondet.hs index b98b368ff..83e5fec96 100644 --- a/src/GF/Conversion/SimpleToMCFG/Nondet.hs +++ b/src/GF/Conversion/SimpleToMCFG/Nondet.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:49 $ +-- > CVS $Date: 2005/04/12 10:49:44 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Converting SimpleGFC grammars to MCFG grammars, nondeterministically. -- Afterwards, the grammar has to be extended with coercion functions, @@ -40,19 +40,19 @@ import GF.Data.BacktrackM type CnvMonad a = BacktrackM Env a -type Env = (MCat, [MCat], LinRec, [LinType]) -type LinRec = [Lin Cat MLabel Token] +type Env = (MCat, [MCat], LinRec, [SLinType]) +type LinRec = [Lin SCat MLabel Token] ---------------------------------------------------------------------- -- main conversion function -convertGrammar :: SimpleGrammar -> MGrammar +convertGrammar :: SGrammar -> MGrammar convertGrammar rules = tracePrt "Nondet conversion: #MCFG rules" (prt . length) $ solutions conversion undefined where conversion = member rules >>= convertRule -convertRule :: SimpleRule -> CnvMonad MRule +convertRule :: SRule -> CnvMonad MRule convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) = do let cat : args = map decl2cat (decl : decls) writeState (initialMCat cat, map initialMCat args, [], ctypes) @@ -68,7 +68,7 @@ convertRule _ = failure ---------------------------------------------------------------------- -- term simplification -simplifyTerm :: Term -> CnvMonad Term +simplifyTerm :: STerm -> CnvMonad STerm simplifyTerm (term :! sel) = do sterm <- simplifyTerm term ssel <- simplifyTerm sel @@ -90,17 +90,17 @@ simplifyTerm term = return term -- (LI Ident) - pattern variable -- (EInt Integer) - integer -simplifyAssign :: (Label, Term) -> CnvMonad (Label, Term) +simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm) simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term -simplifyCase :: (Term, Term) -> CnvMonad (Term, Term) +simplifyCase :: (STerm, STerm) -> CnvMonad (STerm, STerm) simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term) ------------------------------------------------------------ -- reducing simplified terms, collecting MCF rules -reduceTerm :: LinType -> Path -> Term -> CnvMonad () +reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad () reduceTerm ctype path (Variants terms) = member terms >>= reduceTerm ctype path reduceTerm (StrT) path term = updateLin (path, term) @@ -117,7 +117,7 @@ reduceTerm (TblT ptype vtype) path table ------------------------------------------------------------ -- expanding a term to ground terms -expandTerm :: Term -> CnvMonad Term +expandTerm :: STerm -> CnvMonad STerm expandTerm arg@(Arg nr _ path) = do ctypes <- readArgCTypes pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr @@ -128,14 +128,14 @@ expandTerm (Rec record) = liftM Rec $ mapM expandAssign record expandTerm (Variants terms) = member terms >>= expandTerm expandTerm term = error $ "expandTerm: " ++ prt term -expandAssign :: (Label, Term) -> CnvMonad (Label, Term) +expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm) expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term ------------------------------------------------------------ -- unification of patterns and selection terms -(=?=) :: Term -> Term -> CnvMonad () +(=?=) :: STerm -> STerm -> CnvMonad () Wildcard =?= _ = return () Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) | (lbl, pat) <- precord ] @@ -151,7 +151,7 @@ pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term ------------------------------------------------------------ -- updating the MCF rule -readArgCTypes :: CnvMonad [LinType] +readArgCTypes :: CnvMonad [SLinType] readArgCTypes = do (_, _, _, env) <- readState return env @@ -174,7 +174,7 @@ updateLin (path, term) let lins' = lins ++ map (Lin path) newLins writeState (head, args, lins', env) -term2lins :: Term -> [[Symbol (Cat, Path, Int) Token]] +term2lins :: STerm -> [[Symbol (SCat, SPath, Int) Token]] term2lins (Arg nr cat path) = return [Cat (cat, path, nr)] term2lins (Token str) = return [Tok str] term2lins (t1 :++ t2) = liftM2 (++) (term2lins t1) (term2lins t2) diff --git a/src/GF/Conversion/SimpleToMCFG/Strict.hs b/src/GF/Conversion/SimpleToMCFG/Strict.hs index 17c2293ec..e1fd3ecfa 100644 --- a/src/GF/Conversion/SimpleToMCFG/Strict.hs +++ b/src/GF/Conversion/SimpleToMCFG/Strict.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/11 13:52:49 $ +-- > CVS $Date: 2005/04/12 10:49:45 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Converting SimpleGFC grammars to MCFG grammars, deterministic. -- @@ -37,12 +37,12 @@ import GF.Data.SortedList type CnvMonad a = BacktrackM () a -convertGrammar :: SimpleGrammar -> MGrammar +convertGrammar :: SGrammar -> MGrammar convertGrammar rules = tracePrt "Strict conversion: #MCFG rules" (prt . length) $ solutions conversion undefined where conversion = member rules >>= convertRule -convertRule :: SimpleRule -> CnvMonad MRule +convertRule :: SRule -> CnvMonad MRule convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) = do let cat : args = map decl2cat (decl : decls) args_ctypes = zip3 [0..] args ctypes @@ -59,19 +59,19 @@ convertRule _ = failure ---------------------------------------------------------------------- -- category extraction -extractArg :: [Term] -> (Int, Cat, LinType) -> CnvMonad MCat +extractArg :: [STerm] -> (Int, SCat, SLinType) -> CnvMonad MCat extractArg args (nr, cat, ctype) = extractMCat cat ctype (args !! nr) -extractMCat :: Cat -> LinType -> Term -> CnvMonad MCat +extractMCat :: SCat -> SLinType -> STerm -> CnvMonad MCat extractMCat cat ctype term = member $ map (MCat cat) $ parPaths ctype term -enumerateArg :: (Int, Cat, LinType) -> CnvMonad Term +enumerateArg :: (Int, SCat, SLinType) -> CnvMonad STerm enumerateArg (nr, cat, ctype) = member $ enumerateTerms (Just (Arg nr cat emptyPath)) ctype ---------------------------------------------------------------------- -- Substitute each instantiated parameter path for its instantiation -substitutePaths :: [Term] -> Term -> Term +substitutePaths :: [STerm] -> STerm -> STerm substitutePaths arguments = subst where subst (Arg nr _ path) = termFollowPath path (arguments !! nr) subst (con :^ terms) = con :^ map subst terms @@ -87,7 +87,7 @@ substitutePaths arguments = subst ---------------------------------------------------------------------- -- term paths extaction -termPaths :: LinType -> Term -> [(Path, (LinType, Term))] +termPaths :: SLinType -> STerm -> [(SPath, (SLinType, STerm))] termPaths ctype (Variants terms) = terms >>= termPaths ctype termPaths (RecT rtype) (Rec record) = [ (path ++. lbl, value) | @@ -105,19 +105,19 @@ termPaths ctype term | isBaseType ctype = [ (emptyPath, (ctype, term)) ] [p=>p1;q=>q1] | [p=>p2;q=>q2] ==> [p=>p1|p2;q=>q1|q2] -} -parPaths :: LinType -> Term -> [[(Path, Term)]] +parPaths :: SLinType -> STerm -> [[(SPath, STerm)]] parPaths ctype term = mapM (uncurry (map . (,))) $ groupPairs $ nubsort [ (path, value) | (path, (ConT _ _, value)) <- termPaths ctype term ] -strPaths :: LinType -> Term -> [(Path, Term)] +strPaths :: SLinType -> STerm -> [(SPath, STerm)] strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs paths ] where paths = nubsort [ (path, value) | (path, (StrT, value)) <- termPaths ctype term ] ---------------------------------------------------------------------- -- linearization extraction -extractLin :: [MCat] -> (Path, Term) -> [Lin MCat MLabel Token] +extractLin :: [MCat] -> (SPath, STerm) -> [Lin MCat MLabel Token] extractLin args (path, term) = map (Lin path) (convertLin term) where convertLin (t1 :++ t2) = liftM2 (++) (convertLin t1) (convertLin t2) convertLin (Empty) = [[]] -- cgit v1.2.3