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

support for non-linear grammars

Browse Source
This commit is contained in:
kr.angelov
2006-06-03 17:58:34 +00:00
parent fb32d7f3e9
commit 283379b57f
1 changed files with 47 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files

68
src/GF/Conversion/SimpleToFCFG.hs
View File

@@ -24,7 +24,6 @@ import Control.Monad
import GF.Formalism.Utilities import GF.Formalism.Utilities
import GF.Formalism.GCFG import GF.Formalism.GCFG
import GF.Formalism.FCFG import GF.Formalism.FCFG
import GF.Formalism.MCFG(Lin(..))
import GF.Formalism.SimpleGFC import GF.Formalism.SimpleGFC
import GF.Conversion.Types import GF.Conversion.Types
import GF.Canon.AbsGFC(CIdent(..)) import GF.Canon.AbsGFC(CIdent(..))
@@ -71,24 +70,24 @@ convertRule selector (Rule (Abs decl decls (Name fun profile)) (Cnc ctype ctypes
frulesEnv frulesEnv
(convertTerm selector term [Lin emptyPath []]) (convertTerm selector term [Lin emptyPath []])
(let cat : args = map decl2cat (decl : decls) (let cat : args = map decl2cat (decl : decls)
in (initialFCat cat, map initialFCat args, ctype, ctypes)) in (initialFCat cat, map (\scat -> (initialFCat scat,[])) args, ctype, ctypes))
where where
addRule linRec (newCat', newArgs', _, _) env0 = addRule linRec (newCat', newArgs', _, _) env0 =
let (env1, newCat) = genFCatHead env0 newCat' let (env1, newCat) = genFCatHead env0 newCat'
(env2, newArgs,idxArgs) = foldr (\(fcat,ctype,idx) (env,args,all_args) -> (env2, newArgs,idxArgs) = foldr (\((fcat@(FCat _ cat rcs tcs),xpaths),ctype,idx) (env,args,all_args) ->
let (env1, fcat1) = genFCatArg env fcat ctype let xargs = fcat:[FCat 0 cat [path] tcs | path <- reverse xpaths]
(env1, xargs1) = List.mapAccumL (genFCatArg ctype) env xargs
in case fcat of in case fcat of
FCat _ _ [] _ -> (env , args, all_args) FCat _ _ [] _ -> (env , args, all_args)
_ -> (env1,fcat1:args,(idx,fcat1):all_args)) (env1,[],[]) (zip3 newArgs' ctypes [0..]) _ -> (env1,xargs1++args,(idx,xargs1):all_args)) (env1,[],[]) (zip3 newArgs' ctypes [0..])
(catPaths : argsPaths) = [rcs | (FCat _ _ rcs _) <- (newCat : newArgs)] newLinRec = listArray (0,length linRec-1) [translateLin idxArgs path linRec | path <- case newCat of {FCat _ _ rcs _ -> rcs}]
newLinRec = listArray (0,length linRec-1) [translateLin idxArgs path linRec | path <- catPaths]
(_,newProfile) = List.mapAccumL accumProf 0 newArgs' (_,newProfile) = List.mapAccumL accumProf 0 newArgs'
where where
accumProf nr (FCat _ _ [] _) = (nr, Unify [] ) accumProf nr (FCat _ _ [] _,_ ) = (nr, Unify [] )
accumProf nr _ = (nr+1, Unify [nr]) accumProf nr (_ ,xpaths) = (nr+cnt+1, Unify [nr..nr+cnt])
where cnt = length xpaths
newName = Name fun (profile `composeProfiles` newProfile) newName = Name fun (profile `composeProfiles` newProfile)
rule = FRule (Abs newCat newArgs (Name fun newProfile)) newLinRec rule = FRule (Abs newCat newArgs (Name fun newProfile)) newLinRec
@@ -99,10 +98,12 @@ translateLin idxArgs lbl' [] = array (0,-1) []
translateLin idxArgs lbl' (Lin lbl syms : lins) translateLin idxArgs lbl' (Lin lbl syms : lins)
| lbl' == lbl = listArray (0,length syms-1) (map instSym syms) | lbl' == lbl = listArray (0,length syms-1) (map instSym syms)
| otherwise = translateLin idxArgs lbl' lins | otherwise = translateLin idxArgs lbl' lins
where instSym = symbol (\(_, lbl, nr) -> instCat lbl nr 0 idxArgs) FSymTok where
instCat lbl nr nr' ((idx,arg@(FCat _ _ rcs _)):idxArgs) instSym = symbol (\(_, lbl, nr, xnr) -> instCat lbl nr xnr 0 idxArgs) FSymTok
| nr == idx = FSymCat arg (index lbl rcs 0) nr' instCat lbl nr xnr nr' ((idx,xargs):idxArgs)
| otherwise = instCat lbl nr (nr'+1) idxArgs | nr == idx = let arg@(FCat _ _ rcs _) = xargs !! xnr
in FSymCat arg (index lbl rcs 0) (nr'+xnr)
| otherwise = instCat lbl nr xnr (nr'+length xargs) idxArgs
index lbl' (lbl:lbls) idx index lbl' (lbl:lbls) idx
| lbl' == lbl = idx | lbl' == lbl = idx
@@ -113,9 +114,11 @@ translateLin idxArgs lbl' (Lin lbl syms : lins)
type CnvMonad a = BacktrackM Env a type CnvMonad a = BacktrackM Env a
type Env = (FCat, [FCat], SLinType, [SLinType]) type Env = (FCat, [(FCat,[SPath])], SLinType, [SLinType])
type LinRec = [Lin SCat SPath Token] type LinRec = [Lin SCat SPath Token]
data Lin cat lbl tok = Lin lbl [Symbol (cat, lbl, Int, Int) tok]
convertTerm :: STermSelector -> STerm -> LinRec -> CnvMonad LinRec convertTerm :: STermSelector -> STerm -> LinRec -> CnvMonad LinRec
convertTerm selector (Arg nr cat path) (Lin lbl_path lin : lins) = convertArg selector nr cat path lbl_path lin lins convertTerm selector (Arg nr cat path) (Lin lbl_path lin : lins) = convertArg selector nr cat path lbl_path lin lins
@@ -150,8 +153,8 @@ convertArg (ConSel terms) nr cat path lbl_path lin lins = do
return lins return lins
convertArg StrSel nr cat path lbl_path lin lins = do convertArg StrSel nr cat path lbl_path lin lins = do
projectHead lbl_path projectHead lbl_path
projectArg nr path xnr <- projectArg nr path
return (Lin lbl_path (Cat (cat, path, nr) : lin) : lins) return (Lin lbl_path (Cat (cat, path, nr, xnr) : lin) : lins)
convertCon (ConSel terms) con args lbl_path lin lins = do convertCon (ConSel terms) con args lbl_path lin lins = do
args <- mapM evalTerm args args <- mapM evalTerm args
@@ -224,7 +227,7 @@ unifyPType arg (RecT prec) =
(lbl, ptype) <- prec ] (lbl, ptype) <- prec ]
unifyPType (Arg nr _ path) (ConT terms) = unifyPType (Arg nr _ path) (ConT terms) =
do (_, args, _, _) <- readState do (_, args, _, _) <- readState
let (FCat _ _ _ tcs) = args !! nr let (FCat _ _ _ tcs,_) = args !! nr
case lookup path tcs of case lookup path tcs of
Just term -> return term Just term -> return term
Nothing -> do term <- member terms Nothing -> do term <- member terms
@@ -258,8 +261,8 @@ genFCatHead env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) =
tmap_s = Map.singleton tcs x_fcat tmap_s = Map.singleton tcs x_fcat
rmap_s = Map.singleton rcs tmap_s rmap_s = Map.singleton rcs tmap_s
genFCatArg :: FRulesEnv -> FCat -> SLinType -> (FRulesEnv, FCat) genFCatArg :: SLinType -> FRulesEnv -> FCat -> (FRulesEnv, FCat)
genFCatArg env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) ctype = genFCatArg ctype env@(FRulesEnv last_id fcatSet rules) m1@(FCat _ cat rcs tcs) =
case Map.lookup cat fcatSet >>= Map.lookup rcs of case Map.lookup cat fcatSet >>= Map.lookup rcs of
Just tmap -> case Map.lookup tcs tmap of Just tmap -> case Map.lookup tcs tmap of
Just (Left fcat) -> (env, fcat) Just (Left fcat) -> (env, fcat)
@@ -414,16 +417,27 @@ readArgCType arg = do (_, _, _, ctypes) <- readState
return (ctypes !! arg) return (ctypes !! arg)
restrictArg :: Int -> SPath -> STerm -> CnvMonad () restrictArg :: Int -> SPath -> STerm -> CnvMonad ()
restrictArg arg path term restrictArg nr path term = do
= do (head, args, ctype, ctypes) <- readState (head, args, ctype, ctypes) <- readState
args' <- updateNthM (restrictFCat path term) arg args args' <- updateNthM (\(fcat,xs) -> do fcat <- restrictFCat path term fcat
return (fcat,xs) ) nr args
writeState (head, args', ctype, ctypes) writeState (head, args', ctype, ctypes)
projectArg :: Int -> SPath -> CnvMonad () projectArg :: Int -> SPath -> CnvMonad Int
projectArg arg path projectArg nr path = do
= do (head, args, ctype, ctypes) <- readState (head, args, ctype, ctypes) <- readState
args' <- updateNthM (projectFCat path) arg args (xnr,args') <- updateArgs nr args
writeState (head, args', ctype, ctypes) writeState (head, args', ctype, ctypes)
return xnr
where
updateArgs :: Int -> [(FCat,[SPath])] -> CnvMonad (Int,[(FCat,[SPath])])
updateArgs 0 ((a@(FCat _ _ rcs _),xpaths) : as)
| path `elem` rcs = return (length xpaths+1,(a,path:xpaths):as)
| otherwise = do a <- projectFCat path a
return (0,(a,xpaths):as)
updateArgs n (a : as) = do
(xnr,as) <- updateArgs (n-1) as
return (xnr,a:as)
readHeadCType :: CnvMonad SLinType readHeadCType :: CnvMonad SLinType
readHeadCType = do (_, _, ctype, _) <- readState readHeadCType = do (_, _, ctype, _) <- readState