mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-28 22:12:51 -06:00
"Committed_by_peb"
This commit is contained in:
peb
@@ -4,9 +4,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:49 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
-- > CVS $Date: 2005/05/09 09:28:43 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- All conversions from GFC
|
||||
-----------------------------------------------------------------------------
|
||||
@@ -17,8 +17,13 @@ module GF.Conversion.GFC
|
||||
|
||||
import GF.Infra.Option
|
||||
import GF.Canon.GFC (CanonGrammar)
|
||||
import GF.Infra.Ident (Ident)
|
||||
import GF.Conversion.Types (CGrammar, MGrammar, EGrammar, SGrammar)
|
||||
import GF.Infra.Ident (Ident, identC)
|
||||
|
||||
import GF.Formalism.GCFG (Rule(..), Abstract(..))
|
||||
import GF.Formalism.SimpleGFC (decl2cat)
|
||||
import GF.Formalism.CFG (CFRule(..))
|
||||
import GF.Formalism.Utilities (symbol)
|
||||
import GF.Conversion.Types
|
||||
|
||||
import qualified GF.Conversion.GFCtoSimple as G2S
|
||||
import qualified GF.Conversion.SimpleToFinite as S2Fin
|
||||
@@ -27,13 +32,17 @@ import qualified GF.Conversion.RemoveErasing as RemEra
|
||||
import qualified GF.Conversion.SimpleToMCFG as S2M
|
||||
import qualified GF.Conversion.MCFGtoCFG as M2C
|
||||
|
||||
import GF.Infra.Print
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * GFC -> MCFG & CFG, using options to decide which conversion is used
|
||||
|
||||
gfc2mcfg2cfg :: Options -> (CanonGrammar, Ident) -> (MGrammar, CGrammar)
|
||||
gfc2mcfg2cfg opts = \g -> let e = g2e g in (e2m e, e2c e)
|
||||
where e2c = mcfg2cfg
|
||||
e2m = removeErasing
|
||||
e2m = case getOptVal opts firstCat of
|
||||
Just cat -> flip removeErasing [identC cat]
|
||||
Nothing -> flip removeErasing []
|
||||
g2e = case getOptVal opts gfcConversion of
|
||||
Just "strict" -> simple2mcfg_strict . gfc2simple
|
||||
Just "finite" -> simple2mcfg_nondet . gfc2finite
|
||||
@@ -70,8 +79,44 @@ simple2mcfg_strict = S2M.convertGrammarStrict
|
||||
mcfg2cfg :: EGrammar -> CGrammar
|
||||
mcfg2cfg = M2C.convertGrammar
|
||||
|
||||
removeErasing :: EGrammar -> MGrammar
|
||||
removeErasing = RemEra.convertGrammar
|
||||
removeErasing :: EGrammar -> [SCat] -> MGrammar
|
||||
removeErasing = RemEra.convertGrammar
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- * converting to some obscure formats
|
||||
|
||||
gfc2abstract :: (CanonGrammar, Ident) -> [Abstract SCat Fun]
|
||||
gfc2abstract gr = [ Abs (decl2cat decl) (map decl2cat decls) (name2fun name) |
|
||||
Rule (Abs decl decls name) _ <- gfc2simple gr ]
|
||||
|
||||
abstract2prolog :: [Abstract SCat Fun] -> String
|
||||
abstract2prolog gr = skvatt_hdr ++ concatMap abs2pl gr
|
||||
where abs2pl (Abs cat [] fun) = prtQuoted cat ++ " ---> " ++
|
||||
"\"" ++ prt fun ++ "\".\n"
|
||||
abs2pl (Abs cat cats fun) =
|
||||
prtQuoted cat ++ " ---> " ++
|
||||
"\"(" ++ prt fun ++ "\"" ++
|
||||
prtBefore ", \" \", " (map prtQuoted cats) ++ ", \")\".\n"
|
||||
|
||||
cfg2prolog :: CGrammar -> String
|
||||
cfg2prolog gr = skvatt_hdr ++ concatMap cfg2pl gr
|
||||
where cfg2pl (CFRule cat syms _name) =
|
||||
prtQuoted cat ++ " ---> " ++
|
||||
if null syms then "\"\".\n" else
|
||||
prtSep ", " (map (symbol prtQuoted prTok) syms) ++ ".\n"
|
||||
prTok tok = "\"" ++ tok ++ " \""
|
||||
|
||||
skvatt_hdr = ":- use_module(library(skvatt)).\n" ++
|
||||
":- use_module(library(utils), [repeat/1]).\n" ++
|
||||
"corpus(File, StartCat, Depth, Size) :- \n" ++
|
||||
" set_flag(gendepth, Depth),\n" ++
|
||||
" tell(File), repeat(Size),\n" ++
|
||||
" generate_words(StartCat, String), format('~s~n~n', [String]),\n" ++
|
||||
" write(user_error, '.'),\n" ++
|
||||
" fail ; told.\n\n"
|
||||
|
||||
prtQuoted :: Print a => a -> String
|
||||
prtQuoted a = "'" ++ prt a ++ "'"
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -4,13 +4,17 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:50 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
-- > CVS $Date: 2005/05/09 09:28:43 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
-- Converting GFC to SimpleGFC
|
||||
--
|
||||
-- the conversion might fail if the GFC grammar has dependent or higher-order types
|
||||
-- the conversion might fail if the GFC grammar has dependent or higher-order types,
|
||||
-- or if the grammar contains bound pattern variables
|
||||
-- (use -optimize=values/share/none when importing)
|
||||
--
|
||||
-- TODO: lift all functions to the 'Err' monad
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Conversion.GFCtoSimple
|
||||
@@ -38,7 +42,7 @@ type Env = (CanonGrammar, I.Ident)
|
||||
|
||||
convertGrammar :: Env -> SGrammar
|
||||
convertGrammar gram = trace2 "GFCtoSimple - concrete language" (prt (snd gram)) $
|
||||
tracePrt "GFCtoSimple - nr. simpleGFC rules" (prt . length) $
|
||||
tracePrt "GFCtoSimple - simpleGFC rules" (prt . length) $
|
||||
[ convertAbsFun gram fun typing |
|
||||
A.Mod (A.MTAbs modname) _ _ _ defs <- modules,
|
||||
A.AbsDFun fun typing _ <- defs ]
|
||||
@@ -63,21 +67,21 @@ convertAbstract env fun a
|
||||
convertType :: Var -> [TTerm] -> A.Exp -> SDecl
|
||||
convertType x args (A.EApp a b) = convertType x (convertExp [] b : args) a
|
||||
convertType x args (A.EAtom at) = Decl x (convertCat at) args
|
||||
convertType x args exp = error $ "convertType: " ++ prt exp
|
||||
convertType x args exp = error $ "GFCtoSimple.convertType: " ++ prt exp
|
||||
|
||||
convertExp :: [TTerm] -> A.Exp -> TTerm
|
||||
convertExp args (A.EAtom at) = convertAtom args at
|
||||
convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a
|
||||
convertExp args exp = error $ "convertExp: " ++ prt exp
|
||||
convertExp args exp = error $ "GFCtoSimple.convertExp: " ++ prt exp
|
||||
|
||||
convertAtom :: [TTerm] -> A.Atom -> TTerm
|
||||
convertAtom args (A.AC con) = con :@ reverse args
|
||||
convertAtom [] (A.AV var) = TVar var
|
||||
convertAtom args atom = error $ "convertAtom: " ++ prt args ++ " " ++ prt atom
|
||||
convertAtom args atom = error $ "GFCtoSimple.convertAtom: " ++ prt args ++ " " ++ prt atom
|
||||
|
||||
convertCat :: A.Atom -> SCat
|
||||
convertCat (A.AC (A.CIQ _ cat)) = cat
|
||||
convertCat atom = error $ "convertCat: " ++ show atom
|
||||
convertCat atom = error $ "GFCtoSimple.convertCat: " ++ show atom
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- concrete definitions
|
||||
@@ -88,45 +92,43 @@ convertConcrete gram (Abs decl args name) = Cnc ltyp largs term
|
||||
ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args)
|
||||
|
||||
convertCType :: Env -> A.CType -> SLinType
|
||||
convertCType gram (A.RecType rec)
|
||||
= RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ]
|
||||
convertCType gram (A.Table ptype vtype)
|
||||
= TblT (convertCType gram ptype) (convertCType gram vtype)
|
||||
convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct
|
||||
convertCType gram (A.TStr) = StrT
|
||||
convertCType gram (A.TInts n) = error "convertCType: cannot handle 'TInts' constructor"
|
||||
convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- rec ]
|
||||
convertCType gram (A.Table pt vt) = TblT (convertCType gram pt) (convertCType gram vt)
|
||||
convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct
|
||||
convertCType gram (A.TStr) = StrT
|
||||
convertCType gram (A.TInts n) = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor"
|
||||
|
||||
convertTerm :: Env -> A.Term -> STerm
|
||||
convertTerm gram (A.Arg arg) = convertArgVar arg
|
||||
convertTerm gram (A.Arg arg) = convertArgVar arg
|
||||
convertTerm gram (A.Con con terms) = con :^ map (convertTerm gram) terms
|
||||
convertTerm gram (A.LI var) = Var var
|
||||
convertTerm gram (A.R rec) = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ]
|
||||
convertTerm gram (A.P term lbl) = convertTerm gram term +. lbl
|
||||
-- convertTerm gram (A.LI var) = Var var
|
||||
convertTerm gram (A.R rec) = Rec [ (lbl, convertTerm gram term) | A.Ass lbl term <- rec ]
|
||||
convertTerm gram (A.P term lbl) = convertTerm gram term +. lbl
|
||||
convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) |
|
||||
(pat, term) <- zip (groundTerms gram ctype) terms ]
|
||||
convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) |
|
||||
A.Cas pats term <- tbl, pat <- pats ]
|
||||
convertTerm gram (A.S term sel) = convertTerm gram term +! convertTerm gram sel
|
||||
convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) |
|
||||
A.Cas pats term <- tbl, pat <- pats ]
|
||||
convertTerm gram (A.S term sel) = convertTerm gram term :! convertTerm gram sel
|
||||
convertTerm gram (A.C term1 term2) = convertTerm gram term1 ?++ convertTerm gram term2
|
||||
convertTerm gram (A.FV terms) = variants (map (convertTerm gram) terms)
|
||||
convertTerm gram (A.FV terms) = variants (map (convertTerm gram) terms)
|
||||
convertTerm gram (A.E) = Empty
|
||||
convertTerm gram (A.K (A.KS tok)) = Token tok
|
||||
-- 'pre' tokens are converted to variants (over-generating):
|
||||
convertTerm gram (A.K (A.KP [s] vs))
|
||||
= variants $ Token s : [ Token v | A.Var [v] _ <- vs ]
|
||||
convertTerm gram (A.K (A.KP _ _)) = error "convertTerm: don't know how to handle string lists in 'pre' tokens"
|
||||
convertTerm gram (A.K (A.KS tok)) = Token tok
|
||||
convertTerm gram (A.E) = Empty
|
||||
convertTerm gram (A.I con) = error "convertTerm: cannot handle 'I' constructor"
|
||||
convertTerm gram (A.EInt int) = error "convertTerm: cannot handle 'EInt' constructor"
|
||||
convertTerm gram (A.K (A.KP strs vars))
|
||||
= variants $ map conc $ strs : [ vs | A.Var vs _ <- vars ]
|
||||
where conc = foldr1 (?++) . map Token
|
||||
convertTerm gram (A.I con) = error "GFCtoSimple.convertTerm: cannot handle 'I' constructor"
|
||||
convertTerm gram (A.EInt int) = error "GFCtoSimple.convertTerm: cannot handle 'EInt' constructor"
|
||||
|
||||
convertArgVar :: A.ArgVar -> STerm
|
||||
convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath
|
||||
convertArgVar (A.A cat nr) = Arg (fromInteger nr) cat emptyPath
|
||||
convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath
|
||||
|
||||
convertPatt (A.PC con pats) = con :^ map convertPatt pats
|
||||
convertPatt (A.PV x) = Var x
|
||||
convertPatt (A.PW) = Wildcard
|
||||
convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ]
|
||||
convertPatt (A.PI n) = error "convertPatt: cannot handle 'PI' constructor"
|
||||
-- convertPatt (A.PV x) = Var x
|
||||
-- convertPatt (A.PW) = Wildcard
|
||||
convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ]
|
||||
convertPatt (A.PI n) = error "GFCtoSimple.convertPatt: cannot handle 'PI' constructor"
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
|
||||
@@ -4,9 +4,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:51 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
-- > CVS $Date: 2005/05/09 09:28:43 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
-- Converting MCFG grammars to (possibly overgenerating) CFG
|
||||
-----------------------------------------------------------------------------
|
||||
@@ -29,7 +29,7 @@ import GF.Conversion.Types
|
||||
-- * converting (possibly erasing) MCFG grammars
|
||||
|
||||
convertGrammar :: EGrammar -> CGrammar
|
||||
convertGrammar gram = tracePrt "MCFGtoCFG - nr. context-free rules" (prt.length) $
|
||||
convertGrammar gram = tracePrt "MCFGtoCFG - context-free rules" (prt.length) $
|
||||
concatMap convertRule gram
|
||||
|
||||
convertRule :: ERule -> [CRule]
|
||||
|
||||
@@ -4,9 +4,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:53 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.2 $
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.3 $
|
||||
--
|
||||
-- Removing erasingness from MCFG grammars (as in Ljunglöf 2004, sec 4.5.1)
|
||||
-----------------------------------------------------------------------------
|
||||
@@ -18,7 +18,7 @@ module GF.Conversion.RemoveErasing
|
||||
import GF.System.Tracing
|
||||
import GF.Infra.Print
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad
|
||||
import Data.List (mapAccumL)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import GF.Formalism.Utilities
|
||||
@@ -29,18 +29,23 @@ import GF.Data.Assoc
|
||||
import GF.Data.SortedList
|
||||
import GF.Data.GeneralDeduction
|
||||
|
||||
convertGrammar :: EGrammar -> MGrammar
|
||||
convertGrammar grammar
|
||||
= tracePrt "RemoveErasing - nr. nonerasing rules" (prt . length) $
|
||||
traceCalcFirst finalChart $
|
||||
trace2 "RemoveErasing - nr. nonerasing cats" (prt $ length $ chartLookup finalChart False) $
|
||||
trace2 "RemoveErasing - nr. initial ne-cats" (prt $ length initialCats) $
|
||||
trace2 "RemoveErasing - nr. erasing rules" (prt $ length grammar) $
|
||||
newGrammar
|
||||
where newGrammar = [ rule | NR rule <- chartLookup finalChart True ]
|
||||
finalChart = buildChart keyof [newRules rulesByCat] initialCats
|
||||
initialCats = initialCatsBU rulesByCat
|
||||
rulesByCat = accumAssoc id [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- grammar ]
|
||||
convertGrammar :: EGrammar -> [SCat] -> MGrammar
|
||||
convertGrammar grammar starts = newGrammar
|
||||
where newGrammar = tracePrt "RemoveErasing - nonerasing rules" (prt . length) $
|
||||
[ rule | NR rule <- chartLookup finalChart True ]
|
||||
finalChart = tracePrt "RemoveErasing - nonerasing cats"
|
||||
(prt . length . flip chartLookup False) $
|
||||
buildChart keyof [newRules rulesByCat] $
|
||||
tracePrt "RemoveErasing - initial ne-cats" (prt . length) $
|
||||
initialCats
|
||||
initialCats = trace2 "RemoveErasing - starting categories" (prt starts) $
|
||||
if null starts
|
||||
then trace2 "RemoveErasing" "initialCatsBU" $
|
||||
initialCatsBU rulesByCat
|
||||
else trace2 "RemoveErasing" ("initialCatsTD: " ++ prt starts) $
|
||||
initialCatsTD rulesByCat starts
|
||||
rulesByCat = trace2 "RemoveErasing - erasing rules" (prt $ length grammar) $
|
||||
accumAssoc id [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- grammar ]
|
||||
|
||||
data Item r c = NR r | NC c deriving (Eq, Ord, Show)
|
||||
|
||||
@@ -77,8 +82,13 @@ newRules grammar chart (NC newCat@(MCat cat lbls))
|
||||
accumProf nr = maybe (nr, Unify []) $ const (nr+1, Unify [nr])
|
||||
newName = Name fun (newProfile `composeProfiles` profile)
|
||||
|
||||
guard $ all (not . null) argLbls
|
||||
return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins))
|
||||
|
||||
initialCatsTD grammar starts =
|
||||
[ cat | cat@(NC (MCat (ECat start _) _)) <- initialCatsBU grammar,
|
||||
start `elem` starts ]
|
||||
|
||||
initialCatsBU grammar
|
||||
= [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar,
|
||||
let Rule _ (Cnc lbls _ _) = head rules,
|
||||
|
||||
@@ -4,9 +4,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:54 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.3 $
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- Instantiating all types which only have one single element.
|
||||
--
|
||||
@@ -30,7 +30,7 @@ import Data.List (mapAccumL)
|
||||
|
||||
convertGrammar :: SGrammar -> SGrammar
|
||||
convertGrammar grammar = if singles == emptyAssoc then grammar
|
||||
else tracePrt "RemoveSingletons - nr. non-singleton rules" (prt . length) $
|
||||
else tracePrt "RemoveSingletons - non-singleton rules" (prt . length) $
|
||||
map (convertRule singles) grammar
|
||||
where singles = calcSingletons grammar
|
||||
|
||||
|
||||
@@ -4,9 +4,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:57 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- Adding coercion functions to a MCFG if necessary.
|
||||
-----------------------------------------------------------------------------
|
||||
@@ -33,9 +33,9 @@ addCoercions rules = coercions ++ rules
|
||||
Rule (Abs head args _) (Cnc lbls _ _) <- rules ]
|
||||
allHeadSet = nubsort allHeads
|
||||
allArgSet = union allArgs <\\> map fst allHeadSet
|
||||
coercions = tracePrt "SimpleToMCFG.Coercions - nr. MCFG coercions" (prt . length) $
|
||||
coercions = tracePrt "SimpleToMCFG.Coercions - MCFG coercions" (prt . length) $
|
||||
concat $
|
||||
tracePrt "SimpleToMCFG.Coerciions - nr. MCFG coercions per category"
|
||||
tracePrt "SimpleToMCFG.Coercions - MCFG coercions per category"
|
||||
(prtList . map length) $
|
||||
combineCoercions
|
||||
(groupBy sameECatFst allHeadSet)
|
||||
|
||||
@@ -4,9 +4,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:57 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- Converting SimpleGFC grammars to MCFG grammars, nondeterministically.
|
||||
-- Afterwards, the grammar has to be extended with coercion functions,
|
||||
@@ -33,36 +33,72 @@ import GF.Formalism.SimpleGFC
|
||||
import GF.Conversion.Types
|
||||
|
||||
import GF.Data.BacktrackM
|
||||
|
||||
import GF.Data.Utilities (notLongerThan, updateNthM)
|
||||
|
||||
------------------------------------------------------------
|
||||
-- type declarations
|
||||
|
||||
type CnvMonad a = BacktrackM Env a
|
||||
|
||||
type Env = (ECat, [ECat], LinRec, [SLinType])
|
||||
type Env = (ECat, [ECat], LinRec, [SLinType]) -- variable bindings: [(Var, STerm)]
|
||||
type LinRec = [Lin SCat MLabel Token]
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- main conversion function
|
||||
|
||||
convertGrammar :: SGrammar -> EGrammar
|
||||
convertGrammar rules = tracePrt "SimpleToMCFG.Nondet - nr. MCFG rules" (prt . length) $
|
||||
solutions conversion undefined
|
||||
where conversion = member rules >>= convertRule
|
||||
maxNrRules :: Int
|
||||
maxNrRules = 1000
|
||||
|
||||
convertRule :: SRule -> CnvMonad ERule
|
||||
convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term)))
|
||||
= do let cat : args = map decl2cat (decl : decls)
|
||||
writeState (initialECat cat, map initialECat args, [], ctypes)
|
||||
rterm <- simplifyTerm term
|
||||
reduceTerm ctype emptyPath rterm
|
||||
(newCat, newArgs, linRec, _) <- readState
|
||||
let newLinRec = map (instantiateArgs newArgs) linRec
|
||||
catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
|
||||
return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec)
|
||||
convertRule _ = failure
|
||||
convertGrammar :: SGrammar -> EGrammar
|
||||
convertGrammar rules = traceCalcFirst rules' $
|
||||
tracePrt "SimpleToMCFG.Nondet - MCFG rules" (prt . length) $
|
||||
rules'
|
||||
where rules' = rules >>= convertRule
|
||||
-- solutions conversion undefined
|
||||
-- where conversion = member rules >>= convertRule
|
||||
|
||||
convertRule :: SRule -> [ERule] -- CnvMonad ERule
|
||||
convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) =
|
||||
-- | prt(name2fun fun) `elem`
|
||||
-- words "UseCl PosTP TPast ASimul SPredV IndefOneNP DefOneNP UseN2 mother_N2 jump_V" =
|
||||
if notLongerThan maxNrRules rules
|
||||
then tracePrt ("SimpeToMCFG.Nondet - MCFG rules for " ++ prt fun) (prt . length) $
|
||||
rules
|
||||
else trace2 "SimpeToMCFG.Nondet - TOO MANY RULES, function not converted"
|
||||
("More than " ++ show maxNrRules ++ " MCFG rules for " ++ prt fun) $
|
||||
[]
|
||||
where rules = flip solutions undefined $
|
||||
do let cat : args = map decl2cat (decl : decls)
|
||||
writeState (initialECat cat, map initialECat args, [], ctypes)
|
||||
rterm <- simplifyTerm term
|
||||
reduceTerm ctype emptyPath rterm
|
||||
(newCat, newArgs, linRec, _) <- readState
|
||||
let newLinRec = map (instantiateArgs newArgs) linRec
|
||||
catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
|
||||
-- checkLinRec argsPaths catPaths newLinRec
|
||||
return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec)
|
||||
convertRule _ = [] -- failure
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- "type-checking" the resulting linearization
|
||||
-- should not be necessary, if the algorithms (type-checking and conversion) are correct
|
||||
|
||||
checkLinRec args lbls = mapM (checkLin args lbls)
|
||||
|
||||
checkLin args lbls (Lin lbl lin)
|
||||
| lbl `elem` lbls = mapM (symbol (checkArg args) (const (return ()))) lin
|
||||
| otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" "Label mismatch" $
|
||||
failure
|
||||
|
||||
checkArg args (_cat, lbl, nr)
|
||||
| lbl `elem` (args !! nr) = return ()
|
||||
-- | otherwise = trace2 "SimpleToMCFG.Nondet - ERROR" ("Label mismatch in arg " ++ prt nr) $
|
||||
-- failure
|
||||
| otherwise = trace2 ("SimpleToMCFG.Nondet - ERROR: Label mismatch in arg " ++ prt nr)
|
||||
(prt lbl ++ " `notElem` " ++ prt (args!!nr)) $
|
||||
failure
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
@@ -78,6 +114,7 @@ simplifyTerm (term :! sel)
|
||||
return val
|
||||
_ -> do sel' <- expandTerm ssel
|
||||
return (sterm +! sel')
|
||||
-- simplifyTerm (Var x) = readBinding x
|
||||
simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms
|
||||
simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record
|
||||
simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term
|
||||
@@ -85,10 +122,6 @@ simplifyTerm (Tbl table) = liftM Tbl $ mapM simplifyCase table
|
||||
simplifyTerm (Variants terms) = liftM Variants $ mapM simplifyTerm terms
|
||||
simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2)
|
||||
simplifyTerm term = return term
|
||||
-- error constructors:
|
||||
-- (I CIdent) - from resource
|
||||
-- (LI Ident) - pattern variable
|
||||
-- (EInt Integer) - integer
|
||||
|
||||
simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
|
||||
simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term
|
||||
@@ -101,8 +134,8 @@ simplifyCase (pat, term) = liftM2 (,) (simplifyTerm pat) (simplifyTerm term)
|
||||
-- reducing simplified terms, collecting MCF rules
|
||||
|
||||
reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad ()
|
||||
reduceTerm ctype path (Variants terms)
|
||||
= member terms >>= reduceTerm ctype path
|
||||
--reduceTerm ctype path (Variants terms)
|
||||
-- = member terms >>= reduceTerm ctype path
|
||||
reduceTerm (StrT) path term = updateLin (path, term)
|
||||
reduceTerm (ConT _ _) path term = do pat <- expandTerm term
|
||||
updateHead (path, pat)
|
||||
@@ -120,23 +153,41 @@ reduceTerm (TblT ptype vtype) path table
|
||||
expandTerm :: STerm -> CnvMonad STerm
|
||||
expandTerm arg@(Arg nr _ path)
|
||||
= do ctypes <- readArgCTypes
|
||||
pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr
|
||||
pat =?= arg
|
||||
return pat
|
||||
unifyPType arg $ lintypeFollowPath path $ ctypes !! nr
|
||||
-- expandTerm arg@(Arg nr _ path)
|
||||
-- = do ctypes <- readArgCTypes
|
||||
-- pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr
|
||||
-- pat =?= arg
|
||||
-- return pat
|
||||
expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms
|
||||
expandTerm (Rec record) = liftM Rec $ mapM expandAssign record
|
||||
--expandTerm (Variants terms) = liftM Variants $ mapM expandTerm terms
|
||||
expandTerm (Variants terms) = member terms >>= expandTerm
|
||||
expandTerm term = error $ "expandTerm: " ++ prt term
|
||||
|
||||
expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
|
||||
expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term
|
||||
|
||||
unifyPType :: STerm -> SLinType -> CnvMonad STerm
|
||||
unifyPType arg (RecT prec) =
|
||||
liftM Rec $
|
||||
sequence [ liftM ((,) lbl) $
|
||||
unifyPType (arg +. lbl) ptype |
|
||||
(lbl, ptype) <- prec ]
|
||||
unifyPType (Arg nr _ path) (ConT con terms) =
|
||||
do (_, args, _, _) <- readState
|
||||
case lookup path (ecatConstraints (args !! nr)) of
|
||||
Just term -> return term
|
||||
Nothing -> do term <- member terms
|
||||
updateArg nr (path, term)
|
||||
return term
|
||||
|
||||
------------------------------------------------------------
|
||||
-- unification of patterns and selection terms
|
||||
|
||||
(=?=) :: STerm -> STerm -> CnvMonad ()
|
||||
Wildcard =?= _ = return ()
|
||||
-- Wildcard =?= _ = return ()
|
||||
-- Var x =?= term = addBinding x term
|
||||
Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) |
|
||||
(lbl, pat) <- precord ]
|
||||
pat =?= Arg nr _ path = updateArg nr (path, pat)
|
||||
@@ -147,6 +198,15 @@ Rec precord =?= Rec record = sequence_ [ maybe mzero (pat =?=) mterm |
|
||||
let mterm = lookup lbl record ]
|
||||
pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- variable bindings (does not work correctly)
|
||||
{-
|
||||
addBinding x term = do (a, b, c, d, bindings) <- readState
|
||||
writeState (a, b, c, d, (x,term):bindings)
|
||||
|
||||
readBinding x = do (_, _, _, _, bindings) <- readState
|
||||
return $ maybe (Var x) id $ lookup x bindings
|
||||
-}
|
||||
|
||||
------------------------------------------------------------
|
||||
-- updating the MCF rule
|
||||
@@ -158,7 +218,7 @@ readArgCTypes = do (_, _, _, env) <- readState
|
||||
updateArg :: Int -> Constraint -> CnvMonad ()
|
||||
updateArg arg cn
|
||||
= do (head, args, lins, env) <- readState
|
||||
args' <- updateNth (addToECat cn) arg args
|
||||
args' <- updateNthM (addToECat cn) arg args
|
||||
writeState (head, args', lins, env)
|
||||
|
||||
updateHead :: Constraint -> CnvMonad ()
|
||||
@@ -193,11 +253,4 @@ addConstraint cn0 (cn : cns)
|
||||
addConstraint cn0 cns = return (cn0 : cns)
|
||||
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- utilities
|
||||
|
||||
updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
|
||||
updateNth update 0 (a : as) = liftM (:as) (update a)
|
||||
updateNth update n (a : as) = liftM (a:) (updateNth update (n-1) as)
|
||||
|
||||
|
||||
|
||||
@@ -4,9 +4,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:58 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- Converting SimpleGFC grammars to MCFG grammars, deterministic.
|
||||
--
|
||||
@@ -39,7 +39,7 @@ import GF.Data.SortedList
|
||||
type CnvMonad a = BacktrackM () a
|
||||
|
||||
convertGrammar :: SGrammar -> EGrammar
|
||||
convertGrammar rules = tracePrt "SimpleToMCFG.Strict - nr. MCFG rules" (prt . length) $
|
||||
convertGrammar rules = tracePrt "SimpleToMCFG.Strict - MCFG rules" (prt . length) $
|
||||
solutions conversion undefined
|
||||
where conversion = member rules >>= convertRule
|
||||
|
||||
|
||||
@@ -4,9 +4,9 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:21:56 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.7 $
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- All possible instantiations of different grammar formats used in conversion from GFC
|
||||
-----------------------------------------------------------------------------
|
||||
@@ -137,6 +137,9 @@ initialECat cat = ECat cat []
|
||||
ecat2scat :: ECat -> SCat
|
||||
ecat2scat (ECat cat _) = cat
|
||||
|
||||
ecatConstraints :: ECat -> [Constraint]
|
||||
ecatConstraints (ECat _ cns) = cns
|
||||
|
||||
sameECat :: ECat -> ECat -> Bool
|
||||
sameECat ec1 ec2 = ecat2scat ec1 == ecat2scat ec2
|
||||
|
||||
|
||||
Reference in New Issue
Block a user