mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-20 18:29:33 -06:00
"Committed_by_peb"
This commit is contained in:
peb
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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) = [[]]
|
||||
|
||||
Reference in New Issue
Block a user