From c1592825c71867711a63293b588fcbc97e52bfc4 Mon Sep 17 00:00:00 2001 From: peb Date: Mon, 18 Apr 2005 13:55:32 +0000 Subject: "Committed_by_peb" --- src/GF/Conversion/SimpleToMCFG/Coercions.hs | 23 ++++++++++++----------- src/GF/Conversion/SimpleToMCFG/Nondet.hs | 22 +++++++++++----------- src/GF/Conversion/SimpleToMCFG/Strict.hs | 25 +++++++++++++------------ 3 files changed, 36 insertions(+), 34 deletions(-) (limited to 'src/GF/Conversion/SimpleToMCFG') diff --git a/src/GF/Conversion/SimpleToMCFG/Coercions.hs b/src/GF/Conversion/SimpleToMCFG/Coercions.hs index a57953061..98dfd3e7e 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/12 10:49:44 $ +-- > CVS $Date: 2005/04/18 14:55:32 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ +-- > CVS $Revision: 1.3 $ -- -- Adding coercion functions to a MCFG if necessary. ----------------------------------------------------------------------------- @@ -27,25 +27,26 @@ import List (groupBy) ---------------------------------------------------------------------- -addCoercions :: MGrammar -> MGrammar +addCoercions :: EGrammar -> EGrammar addCoercions rules = coercions ++ rules where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | Rule (Abs head args _) (Cnc lbls _ _) <- rules ] allHeadSet = nubsort allHeads allArgSet = union allArgs <\\> map fst allHeadSet - coercions = tracePrt "#MCFG coercions" (prt . length) $ + coercions = tracePrt "SimpleToMCFG.Coercions - nr. MCFG coercions" (prt . length) $ concat $ - tracePrt "#MCFG coercions per category" (prtList . map length) $ + tracePrt "SimpleToMCFG.Coerciions - nr. MCFG coercions per category" + (prtList . map length) $ combineCoercions - (groupBy sameCatFst allHeadSet) - (groupBy sameCat allArgSet) - sameCatFst a b = sameCat (fst a) (fst b) + (groupBy sameECatFst allHeadSet) + (groupBy sameECat allArgSet) + sameECatFst a b = sameECat (fst a) (fst b) combineCoercions [] _ = [] combineCoercions _ [] = [] combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) - = case compare (mcat2scat $ fst $ head heads) (mcat2scat $ head args) of + = case compare (ecat2scat $ fst $ head heads) (ecat2scat $ head args) of LT -> combineCoercions allHeads allArgs' GT -> combineCoercions allHeads' allArgs EQ -> makeCoercion heads args : combineCoercions allHeads allArgs @@ -53,9 +54,9 @@ combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) makeCoercion heads args = [ Rule (Abs arg [head] coercionName) (Cnc lbls [lbls] lins) | - (head@(MCat _ headCns), lbls) <- heads, + (head@(ECat _ headCns), lbls) <- heads, let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ], - arg@(MCat _ argCns) <- args, + arg@(ECat _ argCns) <- args, argCns `subset` headCns ] diff --git a/src/GF/Conversion/SimpleToMCFG/Nondet.hs b/src/GF/Conversion/SimpleToMCFG/Nondet.hs index 83e5fec96..46e89c09a 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/12 10:49:44 $ +-- > CVS $Date: 2005/04/18 14:55:32 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ +-- > CVS $Revision: 1.3 $ -- -- Converting SimpleGFC grammars to MCFG grammars, nondeterministically. -- Afterwards, the grammar has to be extended with coercion functions, @@ -40,22 +40,22 @@ import GF.Data.BacktrackM type CnvMonad a = BacktrackM Env a -type Env = (MCat, [MCat], LinRec, [SLinType]) +type Env = (ECat, [ECat], LinRec, [SLinType]) type LinRec = [Lin SCat MLabel Token] ---------------------------------------------------------------------- -- main conversion function -convertGrammar :: SGrammar -> MGrammar -convertGrammar rules = tracePrt "Nondet conversion: #MCFG rules" (prt . length) $ +convertGrammar :: SGrammar -> EGrammar +convertGrammar rules = tracePrt "SimpleToMCFG.Nondet - nr. MCFG rules" (prt . length) $ solutions conversion undefined where conversion = member rules >>= convertRule -convertRule :: SRule -> CnvMonad MRule +convertRule :: SRule -> CnvMonad ERule 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) + writeState (initialECat cat, map initialECat args, [], ctypes) rterm <- simplifyTerm term reduceTerm ctype emptyPath rterm (newCat, newArgs, linRec, _) <- readState @@ -158,13 +158,13 @@ readArgCTypes = do (_, _, _, env) <- readState updateArg :: Int -> Constraint -> CnvMonad () updateArg arg cn = do (head, args, lins, env) <- readState - args' <- updateNth (addToMCat cn) arg args + args' <- updateNth (addToECat cn) arg args writeState (head, args', lins, env) updateHead :: Constraint -> CnvMonad () updateHead cn = do (head, args, lins, env) <- readState - head' <- addToMCat cn head + head' <- addToECat cn head writeState (head', args, lins, env) updateLin :: Constraint -> CnvMonad () @@ -182,8 +182,8 @@ term2lins (Empty) = return [] term2lins (Variants terms) = terms >>= term2lins term2lins term = error $ "term2lins: " ++ show term -addToMCat :: Constraint -> MCat -> CnvMonad MCat -addToMCat cn (MCat cat cns) = liftM (MCat cat) $ addConstraint cn cns +addToECat :: Constraint -> ECat -> CnvMonad ECat +addToECat cn (ECat cat cns) = liftM (ECat cat) $ addConstraint cn cns addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint] addConstraint cn0 (cn : cns) diff --git a/src/GF/Conversion/SimpleToMCFG/Strict.hs b/src/GF/Conversion/SimpleToMCFG/Strict.hs index e1fd3ecfa..9e14c9dc5 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/12 10:49:45 $ +-- > CVS $Date: 2005/04/18 14:55:33 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ +-- > CVS $Revision: 1.3 $ -- -- Converting SimpleGFC grammars to MCFG grammars, deterministic. -- @@ -16,7 +16,8 @@ ----------------------------------------------------------------------------- -module GF.Conversion.SimpleToMCFG.Strict where -- (convertGrammar) where +module GF.Conversion.SimpleToMCFG.Strict + (convertGrammar) where import GF.System.Tracing import GF.Infra.Print @@ -37,18 +38,18 @@ import GF.Data.SortedList type CnvMonad a = BacktrackM () a -convertGrammar :: SGrammar -> MGrammar -convertGrammar rules = tracePrt "Strict conversion: #MCFG rules" (prt . length) $ +convertGrammar :: SGrammar -> EGrammar +convertGrammar rules = tracePrt "SimpleToMCFG.Strict - nr. MCFG rules" (prt . length) $ solutions conversion undefined where conversion = member rules >>= convertRule -convertRule :: SRule -> CnvMonad MRule +convertRule :: SRule -> CnvMonad ERule 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 instArgs <- mapM enumerateArg args_ctypes let instTerm = substitutePaths instArgs term - newCat <- extractMCat cat ctype instTerm + newCat <- extractECat cat ctype instTerm newArgs <- mapM (extractArg instArgs) args_ctypes let linRec = strPaths ctype instTerm >>= extractLin newArgs let newLinRec = map (instantiateArgs newArgs) linRec @@ -59,11 +60,11 @@ convertRule _ = failure ---------------------------------------------------------------------- -- category extraction -extractArg :: [STerm] -> (Int, SCat, SLinType) -> CnvMonad MCat -extractArg args (nr, cat, ctype) = extractMCat cat ctype (args !! nr) +extractArg :: [STerm] -> (Int, SCat, SLinType) -> CnvMonad ECat +extractArg args (nr, cat, ctype) = extractECat cat ctype (args !! nr) -extractMCat :: SCat -> SLinType -> STerm -> CnvMonad MCat -extractMCat cat ctype term = member $ map (MCat cat) $ parPaths ctype term +extractECat :: SCat -> SLinType -> STerm -> CnvMonad ECat +extractECat cat ctype term = member $ map (ECat cat) $ parPaths ctype term enumerateArg :: (Int, SCat, SLinType) -> CnvMonad STerm enumerateArg (nr, cat, ctype) = member $ enumerateTerms (Just (Arg nr cat emptyPath)) ctype @@ -117,7 +118,7 @@ strPaths ctype term = [ (path, variants values) | (path, values) <- groupPairs p ---------------------------------------------------------------------- -- linearization extraction -extractLin :: [MCat] -> (SPath, STerm) -> [Lin MCat MLabel Token] +extractLin :: [ECat] -> (SPath, STerm) -> [Lin ECat 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