forked from GitHub/gf-core
"Committed_by_peb"
This commit is contained in:
peb
@@ -1,14 +1,14 @@
|
|||||||
|
|
||||||
concrete TestVars of TestVarsA = open TestVarsR in {
|
concrete TestVars of TestVarsA = open TestVarsR in {
|
||||||
|
|
||||||
lincat S = { s : XYZ => Str; p : { s : Str; a : AB } };
|
lincat S = {s1:Str; s2:AB => Str};
|
||||||
|
|
||||||
lin a = { s = table { X _ => variants { "x1" ; "x2" };
|
lin
|
||||||
Y => variants { "y1" ; "y2" };
|
|
||||||
_ => variants { "z1" ; "z2" } };
|
f x = { s1 = x.s2 ! A;
|
||||||
p = variants { { s = "s1" ; a = A } ;
|
s2 = table{ y => variants{ x.s2 ! A; x.s1 ++ x.s2 ! y } } };
|
||||||
{ s = "s2" ; a = B } };
|
|
||||||
};
|
a = { s1 = "a" ++ variants{ "b"; "c" };
|
||||||
|
s2 = table{ A => variants{ "A"; "Q" }; B => "B" } };
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -3,7 +3,9 @@ abstract TestVarsA = {
|
|||||||
|
|
||||||
cat S;
|
cat S;
|
||||||
|
|
||||||
fun a : S;
|
fun
|
||||||
|
f : S -> S;
|
||||||
|
a : S;
|
||||||
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:21:49 $
|
-- > CVS $Date: 2005/05/09 09:28:43 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.7 $
|
-- > CVS $Revision: 1.8 $
|
||||||
--
|
--
|
||||||
-- All conversions from GFC
|
-- All conversions from GFC
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -17,8 +17,13 @@ module GF.Conversion.GFC
|
|||||||
|
|
||||||
import GF.Infra.Option
|
import GF.Infra.Option
|
||||||
import GF.Canon.GFC (CanonGrammar)
|
import GF.Canon.GFC (CanonGrammar)
|
||||||
import GF.Infra.Ident (Ident)
|
import GF.Infra.Ident (Ident, identC)
|
||||||
import GF.Conversion.Types (CGrammar, MGrammar, EGrammar, SGrammar)
|
|
||||||
|
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.GFCtoSimple as G2S
|
||||||
import qualified GF.Conversion.SimpleToFinite as S2Fin
|
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.SimpleToMCFG as S2M
|
||||||
import qualified GF.Conversion.MCFGtoCFG as M2C
|
import qualified GF.Conversion.MCFGtoCFG as M2C
|
||||||
|
|
||||||
|
import GF.Infra.Print
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- * GFC -> MCFG & CFG, using options to decide which conversion is used
|
-- * GFC -> MCFG & CFG, using options to decide which conversion is used
|
||||||
|
|
||||||
gfc2mcfg2cfg :: Options -> (CanonGrammar, Ident) -> (MGrammar, CGrammar)
|
gfc2mcfg2cfg :: Options -> (CanonGrammar, Ident) -> (MGrammar, CGrammar)
|
||||||
gfc2mcfg2cfg opts = \g -> let e = g2e g in (e2m e, e2c e)
|
gfc2mcfg2cfg opts = \g -> let e = g2e g in (e2m e, e2c e)
|
||||||
where e2c = mcfg2cfg
|
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
|
g2e = case getOptVal opts gfcConversion of
|
||||||
Just "strict" -> simple2mcfg_strict . gfc2simple
|
Just "strict" -> simple2mcfg_strict . gfc2simple
|
||||||
Just "finite" -> simple2mcfg_nondet . gfc2finite
|
Just "finite" -> simple2mcfg_nondet . gfc2finite
|
||||||
@@ -70,8 +79,44 @@ simple2mcfg_strict = S2M.convertGrammarStrict
|
|||||||
mcfg2cfg :: EGrammar -> CGrammar
|
mcfg2cfg :: EGrammar -> CGrammar
|
||||||
mcfg2cfg = M2C.convertGrammar
|
mcfg2cfg = M2C.convertGrammar
|
||||||
|
|
||||||
removeErasing :: EGrammar -> MGrammar
|
removeErasing :: EGrammar -> [SCat] -> MGrammar
|
||||||
removeErasing = RemEra.convertGrammar
|
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)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:21:50 $
|
-- > CVS $Date: 2005/05/09 09:28:43 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.5 $
|
-- > CVS $Revision: 1.6 $
|
||||||
--
|
--
|
||||||
-- Converting GFC to SimpleGFC
|
-- 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
|
module GF.Conversion.GFCtoSimple
|
||||||
@@ -38,7 +42,7 @@ type Env = (CanonGrammar, I.Ident)
|
|||||||
|
|
||||||
convertGrammar :: Env -> SGrammar
|
convertGrammar :: Env -> SGrammar
|
||||||
convertGrammar gram = trace2 "GFCtoSimple - concrete language" (prt (snd gram)) $
|
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 |
|
[ convertAbsFun gram fun typing |
|
||||||
A.Mod (A.MTAbs modname) _ _ _ defs <- modules,
|
A.Mod (A.MTAbs modname) _ _ _ defs <- modules,
|
||||||
A.AbsDFun fun typing _ <- defs ]
|
A.AbsDFun fun typing _ <- defs ]
|
||||||
@@ -63,21 +67,21 @@ convertAbstract env fun a
|
|||||||
convertType :: Var -> [TTerm] -> A.Exp -> SDecl
|
convertType :: Var -> [TTerm] -> A.Exp -> SDecl
|
||||||
convertType x args (A.EApp a b) = convertType x (convertExp [] b : args) a
|
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 (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 :: [TTerm] -> A.Exp -> TTerm
|
||||||
convertExp args (A.EAtom at) = convertAtom args at
|
convertExp args (A.EAtom at) = convertAtom args at
|
||||||
convertExp args (A.EApp a b) = convertExp (convertExp [] b : args) a
|
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 :: [TTerm] -> A.Atom -> TTerm
|
||||||
convertAtom args (A.AC con) = con :@ reverse args
|
convertAtom args (A.AC con) = con :@ reverse args
|
||||||
convertAtom [] (A.AV var) = TVar var
|
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.Atom -> SCat
|
||||||
convertCat (A.AC (A.CIQ _ cat)) = cat
|
convertCat (A.AC (A.CIQ _ cat)) = cat
|
||||||
convertCat atom = error $ "convertCat: " ++ show atom
|
convertCat atom = error $ "GFCtoSimple.convertCat: " ++ show atom
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- concrete definitions
|
-- 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)
|
ltyp : largs = map (convertCType gram . lookupCType gram) (decl : args)
|
||||||
|
|
||||||
convertCType :: Env -> A.CType -> SLinType
|
convertCType :: Env -> A.CType -> SLinType
|
||||||
convertCType gram (A.RecType rec)
|
convertCType gram (A.RecType rec) = RecT [ (lbl, convertCType gram ctype) | A.Lbg lbl ctype <- 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 (A.Table ptype vtype)
|
convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct
|
||||||
= TblT (convertCType gram ptype) (convertCType gram vtype)
|
convertCType gram (A.TStr) = StrT
|
||||||
convertCType gram ct@(A.Cn con) = ConT con $ map (convertTerm gram) $ groundTerms gram ct
|
convertCType gram (A.TInts n) = error "GFCtoSimple.convertCType: cannot handle 'TInts' constructor"
|
||||||
convertCType gram (A.TStr) = StrT
|
|
||||||
convertCType gram (A.TInts n) = error "convertCType: cannot handle 'TInts' constructor"
|
|
||||||
|
|
||||||
convertTerm :: Env -> A.Term -> STerm
|
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.Con con terms) = con :^ map (convertTerm gram) terms
|
||||||
convertTerm gram (A.LI var) = Var var
|
-- 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.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.P term lbl) = convertTerm gram term +. lbl
|
||||||
convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) |
|
convertTerm gram (A.V ctype terms) = Tbl [ (convertTerm gram pat, convertTerm gram term) |
|
||||||
(pat, term) <- zip (groundTerms gram ctype) terms ]
|
(pat, term) <- zip (groundTerms gram ctype) terms ]
|
||||||
convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) |
|
convertTerm gram (A.T ctype tbl) = Tbl [ (convertPatt pat, convertTerm gram term) |
|
||||||
A.Cas pats term <- tbl, pat <- pats ]
|
A.Cas pats term <- tbl, pat <- pats ]
|
||||||
convertTerm gram (A.S term sel) = convertTerm gram term +! convertTerm gram sel
|
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.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):
|
-- 'pre' tokens are converted to variants (over-generating):
|
||||||
convertTerm gram (A.K (A.KP [s] vs))
|
convertTerm gram (A.K (A.KP strs vars))
|
||||||
= variants $ Token s : [ Token v | A.Var [v] _ <- vs ]
|
= variants $ map conc $ strs : [ vs | A.Var vs _ <- vars ]
|
||||||
convertTerm gram (A.K (A.KP _ _)) = error "convertTerm: don't know how to handle string lists in 'pre' tokens"
|
where conc = foldr1 (?++) . map Token
|
||||||
convertTerm gram (A.K (A.KS tok)) = Token tok
|
convertTerm gram (A.I con) = error "GFCtoSimple.convertTerm: cannot handle 'I' constructor"
|
||||||
convertTerm gram (A.E) = Empty
|
convertTerm gram (A.EInt int) = error "GFCtoSimple.convertTerm: cannot handle 'EInt' constructor"
|
||||||
convertTerm gram (A.I con) = error "convertTerm: cannot handle 'I' constructor"
|
|
||||||
convertTerm gram (A.EInt int) = error "convertTerm: cannot handle 'EInt' constructor"
|
|
||||||
|
|
||||||
convertArgVar :: A.ArgVar -> STerm
|
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
|
convertArgVar (A.AB cat bindings nr) = Arg (fromInteger nr) cat emptyPath
|
||||||
|
|
||||||
convertPatt (A.PC con pats) = con :^ map convertPatt pats
|
convertPatt (A.PC con pats) = con :^ map convertPatt pats
|
||||||
convertPatt (A.PV x) = Var x
|
-- convertPatt (A.PV x) = Var x
|
||||||
convertPatt (A.PW) = Wildcard
|
-- convertPatt (A.PW) = Wildcard
|
||||||
convertPatt (A.PR rec) = Rec [ (lbl, convertPatt pat) | A.PAss lbl pat <- rec ]
|
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.PI n) = error "GFCtoSimple.convertPatt: cannot handle 'PI' constructor"
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:21:51 $
|
-- > CVS $Date: 2005/05/09 09:28:43 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.5 $
|
-- > CVS $Revision: 1.6 $
|
||||||
--
|
--
|
||||||
-- Converting MCFG grammars to (possibly overgenerating) CFG
|
-- Converting MCFG grammars to (possibly overgenerating) CFG
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -29,7 +29,7 @@ import GF.Conversion.Types
|
|||||||
-- * converting (possibly erasing) MCFG grammars
|
-- * converting (possibly erasing) MCFG grammars
|
||||||
|
|
||||||
convertGrammar :: EGrammar -> CGrammar
|
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
|
concatMap convertRule gram
|
||||||
|
|
||||||
convertRule :: ERule -> [CRule]
|
convertRule :: ERule -> [CRule]
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:21:53 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.2 $
|
-- > CVS $Revision: 1.3 $
|
||||||
--
|
--
|
||||||
-- Removing erasingness from MCFG grammars (as in Ljunglöf 2004, sec 4.5.1)
|
-- 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.System.Tracing
|
||||||
import GF.Infra.Print
|
import GF.Infra.Print
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Data.List (mapAccumL)
|
import Data.List (mapAccumL)
|
||||||
import Data.Maybe (mapMaybe)
|
import Data.Maybe (mapMaybe)
|
||||||
import GF.Formalism.Utilities
|
import GF.Formalism.Utilities
|
||||||
@@ -29,18 +29,23 @@ import GF.Data.Assoc
|
|||||||
import GF.Data.SortedList
|
import GF.Data.SortedList
|
||||||
import GF.Data.GeneralDeduction
|
import GF.Data.GeneralDeduction
|
||||||
|
|
||||||
convertGrammar :: EGrammar -> MGrammar
|
convertGrammar :: EGrammar -> [SCat] -> MGrammar
|
||||||
convertGrammar grammar
|
convertGrammar grammar starts = newGrammar
|
||||||
= tracePrt "RemoveErasing - nr. nonerasing rules" (prt . length) $
|
where newGrammar = tracePrt "RemoveErasing - nonerasing rules" (prt . length) $
|
||||||
traceCalcFirst finalChart $
|
[ rule | NR rule <- chartLookup finalChart True ]
|
||||||
trace2 "RemoveErasing - nr. nonerasing cats" (prt $ length $ chartLookup finalChart False) $
|
finalChart = tracePrt "RemoveErasing - nonerasing cats"
|
||||||
trace2 "RemoveErasing - nr. initial ne-cats" (prt $ length initialCats) $
|
(prt . length . flip chartLookup False) $
|
||||||
trace2 "RemoveErasing - nr. erasing rules" (prt $ length grammar) $
|
buildChart keyof [newRules rulesByCat] $
|
||||||
newGrammar
|
tracePrt "RemoveErasing - initial ne-cats" (prt . length) $
|
||||||
where newGrammar = [ rule | NR rule <- chartLookup finalChart True ]
|
initialCats
|
||||||
finalChart = buildChart keyof [newRules rulesByCat] initialCats
|
initialCats = trace2 "RemoveErasing - starting categories" (prt starts) $
|
||||||
initialCats = initialCatsBU rulesByCat
|
if null starts
|
||||||
rulesByCat = accumAssoc id [ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- grammar ]
|
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)
|
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])
|
accumProf nr = maybe (nr, Unify []) $ const (nr+1, Unify [nr])
|
||||||
newName = Name fun (newProfile `composeProfiles` profile)
|
newName = Name fun (newProfile `composeProfiles` profile)
|
||||||
|
|
||||||
|
guard $ all (not . null) argLbls
|
||||||
return $ NR (Rule (Abs newCat newArgs newName) (Cnc lbls argLbls newLins))
|
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
|
initialCatsBU grammar
|
||||||
= [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar,
|
= [ NC (MCat cat [lbl]) | (cat, rules) <- aAssocs grammar,
|
||||||
let Rule _ (Cnc lbls _ _) = head rules,
|
let Rule _ (Cnc lbls _ _) = head rules,
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:21:54 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.3 $
|
-- > CVS $Revision: 1.4 $
|
||||||
--
|
--
|
||||||
-- Instantiating all types which only have one single element.
|
-- Instantiating all types which only have one single element.
|
||||||
--
|
--
|
||||||
@@ -30,7 +30,7 @@ import Data.List (mapAccumL)
|
|||||||
|
|
||||||
convertGrammar :: SGrammar -> SGrammar
|
convertGrammar :: SGrammar -> SGrammar
|
||||||
convertGrammar grammar = if singles == emptyAssoc then grammar
|
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
|
map (convertRule singles) grammar
|
||||||
where singles = calcSingletons grammar
|
where singles = calcSingletons grammar
|
||||||
|
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:21:57 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.4 $
|
-- > CVS $Revision: 1.5 $
|
||||||
--
|
--
|
||||||
-- Adding coercion functions to a MCFG if necessary.
|
-- Adding coercion functions to a MCFG if necessary.
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -33,9 +33,9 @@ addCoercions rules = coercions ++ rules
|
|||||||
Rule (Abs head args _) (Cnc lbls _ _) <- rules ]
|
Rule (Abs head args _) (Cnc lbls _ _) <- rules ]
|
||||||
allHeadSet = nubsort allHeads
|
allHeadSet = nubsort allHeads
|
||||||
allArgSet = union allArgs <\\> map fst allHeadSet
|
allArgSet = union allArgs <\\> map fst allHeadSet
|
||||||
coercions = tracePrt "SimpleToMCFG.Coercions - nr. MCFG coercions" (prt . length) $
|
coercions = tracePrt "SimpleToMCFG.Coercions - MCFG coercions" (prt . length) $
|
||||||
concat $
|
concat $
|
||||||
tracePrt "SimpleToMCFG.Coerciions - nr. MCFG coercions per category"
|
tracePrt "SimpleToMCFG.Coercions - MCFG coercions per category"
|
||||||
(prtList . map length) $
|
(prtList . map length) $
|
||||||
combineCoercions
|
combineCoercions
|
||||||
(groupBy sameECatFst allHeadSet)
|
(groupBy sameECatFst allHeadSet)
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:21:57 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.4 $
|
-- > CVS $Revision: 1.5 $
|
||||||
--
|
--
|
||||||
-- Converting SimpleGFC grammars to MCFG grammars, nondeterministically.
|
-- Converting SimpleGFC grammars to MCFG grammars, nondeterministically.
|
||||||
-- Afterwards, the grammar has to be extended with coercion functions,
|
-- Afterwards, the grammar has to be extended with coercion functions,
|
||||||
@@ -33,36 +33,72 @@ import GF.Formalism.SimpleGFC
|
|||||||
import GF.Conversion.Types
|
import GF.Conversion.Types
|
||||||
|
|
||||||
import GF.Data.BacktrackM
|
import GF.Data.BacktrackM
|
||||||
|
import GF.Data.Utilities (notLongerThan, updateNthM)
|
||||||
|
|
||||||
------------------------------------------------------------
|
------------------------------------------------------------
|
||||||
-- type declarations
|
-- type declarations
|
||||||
|
|
||||||
type CnvMonad a = BacktrackM Env a
|
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]
|
type LinRec = [Lin SCat MLabel Token]
|
||||||
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- main conversion function
|
-- main conversion function
|
||||||
|
|
||||||
convertGrammar :: SGrammar -> EGrammar
|
maxNrRules :: Int
|
||||||
convertGrammar rules = tracePrt "SimpleToMCFG.Nondet - nr. MCFG rules" (prt . length) $
|
maxNrRules = 1000
|
||||||
solutions conversion undefined
|
|
||||||
where conversion = member rules >>= convertRule
|
|
||||||
|
|
||||||
convertRule :: SRule -> CnvMonad ERule
|
convertGrammar :: SGrammar -> EGrammar
|
||||||
convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term)))
|
convertGrammar rules = traceCalcFirst rules' $
|
||||||
= do let cat : args = map decl2cat (decl : decls)
|
tracePrt "SimpleToMCFG.Nondet - MCFG rules" (prt . length) $
|
||||||
writeState (initialECat cat, map initialECat args, [], ctypes)
|
rules'
|
||||||
rterm <- simplifyTerm term
|
where rules' = rules >>= convertRule
|
||||||
reduceTerm ctype emptyPath rterm
|
-- solutions conversion undefined
|
||||||
(newCat, newArgs, linRec, _) <- readState
|
-- where conversion = member rules >>= convertRule
|
||||||
let newLinRec = map (instantiateArgs newArgs) linRec
|
|
||||||
catPaths : argsPaths = map (lintype2paths emptyPath) (ctype : ctypes)
|
convertRule :: SRule -> [ERule] -- CnvMonad ERule
|
||||||
return $ Rule (Abs newCat newArgs fun) (Cnc catPaths argsPaths newLinRec)
|
convertRule (Rule (Abs decl decls fun) (Cnc ctype ctypes (Just term))) =
|
||||||
convertRule _ = failure
|
-- | 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
|
return val
|
||||||
_ -> do sel' <- expandTerm ssel
|
_ -> do sel' <- expandTerm ssel
|
||||||
return (sterm +! sel')
|
return (sterm +! sel')
|
||||||
|
-- simplifyTerm (Var x) = readBinding x
|
||||||
simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms
|
simplifyTerm (con :^ terms) = liftM (con :^) $ mapM simplifyTerm terms
|
||||||
simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record
|
simplifyTerm (Rec record) = liftM Rec $ mapM simplifyAssign record
|
||||||
simplifyTerm (term :. lbl) = liftM (+. lbl) $ simplifyTerm term
|
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 (Variants terms) = liftM Variants $ mapM simplifyTerm terms
|
||||||
simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2)
|
simplifyTerm (term1 :++ term2) = liftM2 (:++) (simplifyTerm term1) (simplifyTerm term2)
|
||||||
simplifyTerm term = return term
|
simplifyTerm term = return term
|
||||||
-- error constructors:
|
|
||||||
-- (I CIdent) - from resource
|
|
||||||
-- (LI Ident) - pattern variable
|
|
||||||
-- (EInt Integer) - integer
|
|
||||||
|
|
||||||
simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
|
simplifyAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
|
||||||
simplifyAssign (lbl, term) = liftM ((,) lbl) $ simplifyTerm term
|
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
|
-- reducing simplified terms, collecting MCF rules
|
||||||
|
|
||||||
reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad ()
|
reduceTerm :: SLinType -> SPath -> STerm -> CnvMonad ()
|
||||||
reduceTerm ctype path (Variants terms)
|
--reduceTerm ctype path (Variants terms)
|
||||||
= member terms >>= reduceTerm ctype path
|
-- = member terms >>= reduceTerm ctype path
|
||||||
reduceTerm (StrT) path term = updateLin (path, term)
|
reduceTerm (StrT) path term = updateLin (path, term)
|
||||||
reduceTerm (ConT _ _) path term = do pat <- expandTerm term
|
reduceTerm (ConT _ _) path term = do pat <- expandTerm term
|
||||||
updateHead (path, pat)
|
updateHead (path, pat)
|
||||||
@@ -120,23 +153,41 @@ reduceTerm (TblT ptype vtype) path table
|
|||||||
expandTerm :: STerm -> CnvMonad STerm
|
expandTerm :: STerm -> CnvMonad STerm
|
||||||
expandTerm arg@(Arg nr _ path)
|
expandTerm arg@(Arg nr _ path)
|
||||||
= do ctypes <- readArgCTypes
|
= do ctypes <- readArgCTypes
|
||||||
pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr
|
unifyPType arg $ lintypeFollowPath path $ ctypes !! nr
|
||||||
pat =?= arg
|
-- expandTerm arg@(Arg nr _ path)
|
||||||
return pat
|
-- = do ctypes <- readArgCTypes
|
||||||
|
-- pat <- member $ enumeratePatterns $ lintypeFollowPath path $ ctypes !! nr
|
||||||
|
-- pat =?= arg
|
||||||
|
-- return pat
|
||||||
expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms
|
expandTerm (con :^ terms) = liftM (con :^) $ mapM expandTerm terms
|
||||||
expandTerm (Rec record) = liftM Rec $ mapM expandAssign record
|
expandTerm (Rec record) = liftM Rec $ mapM expandAssign record
|
||||||
|
--expandTerm (Variants terms) = liftM Variants $ mapM expandTerm terms
|
||||||
expandTerm (Variants terms) = member terms >>= expandTerm
|
expandTerm (Variants terms) = member terms >>= expandTerm
|
||||||
expandTerm term = error $ "expandTerm: " ++ prt term
|
expandTerm term = error $ "expandTerm: " ++ prt term
|
||||||
|
|
||||||
expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
|
expandAssign :: (Label, STerm) -> CnvMonad (Label, STerm)
|
||||||
expandAssign (lbl, term) = liftM ((,) lbl) $ expandTerm term
|
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
|
-- unification of patterns and selection terms
|
||||||
|
|
||||||
(=?=) :: STerm -> STerm -> CnvMonad ()
|
(=?=) :: STerm -> STerm -> CnvMonad ()
|
||||||
Wildcard =?= _ = return ()
|
-- Wildcard =?= _ = return ()
|
||||||
|
-- Var x =?= term = addBinding x term
|
||||||
Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) |
|
Rec precord =?= arg@(Arg _ _ _) = sequence_ [ pat =?= (arg +. lbl) |
|
||||||
(lbl, pat) <- precord ]
|
(lbl, pat) <- precord ]
|
||||||
pat =?= Arg nr _ path = updateArg nr (path, pat)
|
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 ]
|
let mterm = lookup lbl record ]
|
||||||
pat =?= term = error $ "(=?=): " ++ prt pat ++ " =?= " ++ prt term
|
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
|
-- updating the MCF rule
|
||||||
@@ -158,7 +218,7 @@ readArgCTypes = do (_, _, _, env) <- readState
|
|||||||
updateArg :: Int -> Constraint -> CnvMonad ()
|
updateArg :: Int -> Constraint -> CnvMonad ()
|
||||||
updateArg arg cn
|
updateArg arg cn
|
||||||
= do (head, args, lins, env) <- readState
|
= do (head, args, lins, env) <- readState
|
||||||
args' <- updateNth (addToECat cn) arg args
|
args' <- updateNthM (addToECat cn) arg args
|
||||||
writeState (head, args', lins, env)
|
writeState (head, args', lins, env)
|
||||||
|
|
||||||
updateHead :: Constraint -> CnvMonad ()
|
updateHead :: Constraint -> CnvMonad ()
|
||||||
@@ -193,11 +253,4 @@ addConstraint cn0 (cn : cns)
|
|||||||
addConstraint cn0 cns = return (cn0 : 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)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:21:58 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.4 $
|
-- > CVS $Revision: 1.5 $
|
||||||
--
|
--
|
||||||
-- Converting SimpleGFC grammars to MCFG grammars, deterministic.
|
-- Converting SimpleGFC grammars to MCFG grammars, deterministic.
|
||||||
--
|
--
|
||||||
@@ -39,7 +39,7 @@ import GF.Data.SortedList
|
|||||||
type CnvMonad a = BacktrackM () a
|
type CnvMonad a = BacktrackM () a
|
||||||
|
|
||||||
convertGrammar :: SGrammar -> EGrammar
|
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
|
solutions conversion undefined
|
||||||
where conversion = member rules >>= convertRule
|
where conversion = member rules >>= convertRule
|
||||||
|
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:21:56 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.7 $
|
-- > CVS $Revision: 1.8 $
|
||||||
--
|
--
|
||||||
-- All possible instantiations of different grammar formats used in conversion from GFC
|
-- 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 -> SCat
|
||||||
ecat2scat (ECat cat _) = cat
|
ecat2scat (ECat cat _) = cat
|
||||||
|
|
||||||
|
ecatConstraints :: ECat -> [Constraint]
|
||||||
|
ecatConstraints (ECat _ cns) = cns
|
||||||
|
|
||||||
sameECat :: ECat -> ECat -> Bool
|
sameECat :: ECat -> ECat -> Bool
|
||||||
sameECat ec1 ec2 = ecat2scat ec1 == ecat2scat ec2
|
sameECat ec1 ec2 = ecat2scat ec1 == ecat2scat ec2
|
||||||
|
|
||||||
|
|||||||
@@ -5,9 +5,9 @@
|
|||||||
-- Stability : Stable
|
-- Stability : Stable
|
||||||
-- Portability : Haskell 98
|
-- Portability : Haskell 98
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/12 10:49:45 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: peb $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.3 $
|
-- > CVS $Revision: 1.4 $
|
||||||
--
|
--
|
||||||
-- Association lists, or finite maps,
|
-- Association lists, or finite maps,
|
||||||
-- including sets as maps with result type @()@.
|
-- including sets as maps with result type @()@.
|
||||||
@@ -25,6 +25,7 @@ module GF.Data.Assoc ( Assoc,
|
|||||||
aAssocs,
|
aAssocs,
|
||||||
aElems,
|
aElems,
|
||||||
assocMap,
|
assocMap,
|
||||||
|
assocFilter,
|
||||||
lookupAssoc,
|
lookupAssoc,
|
||||||
lookupWith,
|
lookupWith,
|
||||||
(?),
|
(?),
|
||||||
@@ -63,6 +64,9 @@ aElems :: Ord a => Assoc a b -> SList a
|
|||||||
-- the mapping function can take the key as information
|
-- the mapping function can take the key as information
|
||||||
assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b'
|
assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b'
|
||||||
|
|
||||||
|
assocFilter :: Ord a => (b -> Bool) -> Assoc a b -> Assoc a b
|
||||||
|
assocFilter pred = listAssoc . filter (pred . snd) . aAssocs
|
||||||
|
|
||||||
-- | monadic lookup function,
|
-- | monadic lookup function,
|
||||||
-- returning failure if the key does not exist
|
-- returning failure if the key does not exist
|
||||||
lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b
|
lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:22:03 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.2 $
|
-- > CVS $Revision: 1.3 $
|
||||||
--
|
--
|
||||||
-- Implementation of /incremental/ deductive parsing,
|
-- Implementation of /incremental/ deductive parsing,
|
||||||
-- i.e. parsing one word at the time.
|
-- i.e. parsing one word at the time.
|
||||||
@@ -18,7 +18,7 @@ module GF.Data.IncrementalDeduction
|
|||||||
-- * Functions
|
-- * Functions
|
||||||
chartLookup,
|
chartLookup,
|
||||||
buildChart,
|
buildChart,
|
||||||
chartList
|
chartList, chartKeys
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Array
|
import Data.Array
|
||||||
@@ -45,6 +45,8 @@ chartList :: (Ord item, Ord key) =>
|
|||||||
-- the position and the item
|
-- the position and the item
|
||||||
-> [edge]
|
-> [edge]
|
||||||
|
|
||||||
|
chartKeys :: (Ord item, Ord key) => IncrementalChart item key -> Int -> [key]
|
||||||
|
|
||||||
type IncrementalChart item key = Array Int (Assoc key (SList item))
|
type IncrementalChart item key = Array Int (Assoc key (SList item))
|
||||||
|
|
||||||
----------
|
----------
|
||||||
@@ -61,4 +63,5 @@ chartList chart combine = [ combine k item |
|
|||||||
(k, state) <- assocs chart,
|
(k, state) <- assocs chart,
|
||||||
item <- concatMap snd $ aAssocs state ]
|
item <- concatMap snd $ aAssocs state ]
|
||||||
|
|
||||||
|
chartKeys chart k = aElems (chart ! k)
|
||||||
|
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/11 13:52:49 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: peb $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.1 $
|
-- > CVS $Revision: 1.2 $
|
||||||
--
|
--
|
||||||
-- Basic functions not in the standard libraries
|
-- Basic functions not in the standard libraries
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -14,6 +14,8 @@
|
|||||||
|
|
||||||
module GF.Data.Utilities where
|
module GF.Data.Utilities where
|
||||||
|
|
||||||
|
import Monad (liftM)
|
||||||
|
|
||||||
-- * functions on lists
|
-- * functions on lists
|
||||||
|
|
||||||
sameLength :: [a] -> [a] -> Bool
|
sameLength :: [a] -> [a] -> Bool
|
||||||
@@ -21,6 +23,10 @@ sameLength [] [] = True
|
|||||||
sameLength (_:xs) (_:ys) = sameLength xs ys
|
sameLength (_:xs) (_:ys) = sameLength xs ys
|
||||||
sameLength _ _ = False
|
sameLength _ _ = False
|
||||||
|
|
||||||
|
notLongerThan, longerThan :: Int -> [a] -> Bool
|
||||||
|
notLongerThan n = null . snd . splitAt n
|
||||||
|
longerThan n = not . notLongerThan n
|
||||||
|
|
||||||
lookupList :: Eq a => a -> [(a, b)] -> [b]
|
lookupList :: Eq a => a -> [(a, b)] -> [b]
|
||||||
lookupList a [] = []
|
lookupList a [] = []
|
||||||
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
|
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
|
||||||
@@ -42,6 +48,18 @@ foldMerge merge zero = fm
|
|||||||
fm [a] = a
|
fm [a] = a
|
||||||
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
|
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
|
||||||
|
|
||||||
|
select :: [a] -> [(a, [a])]
|
||||||
|
select [] = []
|
||||||
|
select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ]
|
||||||
|
|
||||||
|
updateNth :: (a -> a) -> Int -> [a] -> [a]
|
||||||
|
updateNth update 0 (a : as) = update a : as
|
||||||
|
updateNth update n (a : as) = a : updateNth update (n-1) as
|
||||||
|
|
||||||
|
updateNthM :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
|
||||||
|
updateNthM update 0 (a : as) = liftM (:as) (update a)
|
||||||
|
updateNthM update n (a : as) = liftM (a:) (updateNthM update (n-1) as)
|
||||||
|
|
||||||
-- * functions on pairs
|
-- * functions on pairs
|
||||||
|
|
||||||
mapFst :: (a -> a') -> (a, b) -> (a', b)
|
mapFst :: (a -> a') -> (a, b) -> (a', b)
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/20 12:49:44 $
|
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||||
-- > CVS $Author: peb $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.2 $
|
-- > CVS $Revision: 1.3 $
|
||||||
--
|
--
|
||||||
-- Basic GCFG formalism (derived from Pollard 1984)
|
-- Basic GCFG formalism (derived from Pollard 1984)
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -45,6 +45,7 @@ instance (Print c, Print n) => Print (Abstract c n) where
|
|||||||
else " -> " ++ prtSep " " args )
|
else " -> " ++ prtSep " " args )
|
||||||
|
|
||||||
instance (Print l, Print t) => Print (Concrete l t) where
|
instance (Print l, Print t) => Print (Concrete l t) where
|
||||||
prt (Cnc lcat args term) = prt term ++ " : " ++ prt lcat ++
|
prt (Cnc lcat args term) = prt term
|
||||||
( if null args then ""
|
++ " : " ++ prt lcat ++
|
||||||
else " / " ++ prtSep " " args)
|
( if null args then ""
|
||||||
|
else " / " ++ prtSep " " args)
|
||||||
|
|||||||
@@ -4,20 +4,24 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/11 13:52:50 $
|
-- > CVS $Date: 2005/05/09 09:28:45 $
|
||||||
-- > CVS $Author: peb $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.1 $
|
-- > CVS $Revision: 1.2 $
|
||||||
--
|
--
|
||||||
-- Definitions of multiple context-free grammars
|
-- Definitions of multiple context-free grammars
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module GF.Formalism.MCFG where
|
module GF.Formalism.MCFG where
|
||||||
|
|
||||||
|
import Control.Monad (liftM)
|
||||||
|
import Data.List (groupBy)
|
||||||
|
|
||||||
import GF.Formalism.Utilities
|
import GF.Formalism.Utilities
|
||||||
import GF.Formalism.GCFG
|
import GF.Formalism.GCFG
|
||||||
|
|
||||||
import GF.Infra.Print
|
import GF.Infra.Print
|
||||||
|
|
||||||
|
|
||||||
------------------------------------------------------------
|
------------------------------------------------------------
|
||||||
-- grammar types
|
-- grammar types
|
||||||
|
|
||||||
@@ -35,6 +39,13 @@ instantiateArgs args (Lin lbl lin) = Lin lbl (map instSym lin)
|
|||||||
where instSym = mapSymbol instCat id
|
where instSym = mapSymbol instCat id
|
||||||
instCat (_, lbl, nr) = (args !! nr, lbl, nr)
|
instCat (_, lbl, nr) = (args !! nr, lbl, nr)
|
||||||
|
|
||||||
|
expandVariants :: Eq lbl => MCFRule cat name lbl tok -> [MCFRule cat name lbl tok]
|
||||||
|
expandVariants (Rule abs (Cnc typ typs lins)) = liftM (Rule abs . Cnc typ typs) $
|
||||||
|
expandLins lins
|
||||||
|
where expandLins = sequence . groupBy eqLbl
|
||||||
|
eqLbl (Lin l1 _) (Lin l2 _) = l1 == l2
|
||||||
|
|
||||||
|
|
||||||
------------------------------------------------------------
|
------------------------------------------------------------
|
||||||
-- pretty-printing
|
-- pretty-printing
|
||||||
|
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:22:13 $
|
-- > CVS $Date: 2005/05/09 09:28:45 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.5 $
|
-- > CVS $Revision: 1.6 $
|
||||||
--
|
--
|
||||||
-- Simplistic GFC format
|
-- Simplistic GFC format
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -56,11 +56,12 @@ varsInTTerm tterm = vars tterm []
|
|||||||
|
|
||||||
tterm2term :: TTerm -> Term c t
|
tterm2term :: TTerm -> Term c t
|
||||||
tterm2term (con :@ terms) = con :^ map tterm2term terms
|
tterm2term (con :@ terms) = con :^ map tterm2term terms
|
||||||
tterm2term (TVar x) = Var x
|
-- tterm2term (TVar x) = Var x
|
||||||
|
tterm2term term = error $ "tterm2term: illegal term"
|
||||||
|
|
||||||
term2tterm :: Term c t -> TTerm
|
term2tterm :: Term c t -> TTerm
|
||||||
term2tterm (con :^ terms) = con :@ map term2tterm terms
|
term2tterm (con :^ terms) = con :@ map term2tterm terms
|
||||||
term2tterm (Var x) = TVar x
|
-- term2tterm (Var x) = TVar x
|
||||||
term2tterm term = error $ "term2tterm: illegal term"
|
term2tterm term = error $ "term2tterm: illegal term"
|
||||||
|
|
||||||
-- ** linearization types and terms
|
-- ** linearization types and terms
|
||||||
@@ -88,8 +89,8 @@ data Term c t
|
|||||||
| Term c t :++ Term c t -- ^ concatenation
|
| Term c t :++ Term c t -- ^ concatenation
|
||||||
| Token t -- ^ single token
|
| Token t -- ^ single token
|
||||||
| Empty -- ^ empty string
|
| Empty -- ^ empty string
|
||||||
| Wildcard -- ^ wildcard pattern variable
|
---- | Wildcard -- ^ wildcard pattern variable
|
||||||
| Var Var -- ^ bound pattern variable
|
---- | Var Var -- ^ bound pattern variable
|
||||||
|
|
||||||
-- Res CIdent -- ^ resource identifier
|
-- Res CIdent -- ^ resource identifier
|
||||||
-- Int Integer -- ^ integer
|
-- Int Integer -- ^ integer
|
||||||
@@ -113,6 +114,27 @@ Arg arg cat path +! pat = Arg arg cat (path ++! pat)
|
|||||||
term@(Tbl table) +! pat = maybe (term :! pat) id $ lookup pat table
|
term@(Tbl table) +! pat = maybe (term :! pat) id $ lookup pat table
|
||||||
term +! pat = term :! pat
|
term +! pat = term :! pat
|
||||||
|
|
||||||
|
{- does not work correctly:
|
||||||
|
lookupTbl term [] _ = term
|
||||||
|
lookupTbl _ ((Wildcard, term) : _) _ = term
|
||||||
|
lookupTbl _ ((Var x, term) : _) pat = subst x pat term
|
||||||
|
lookupTbl _ ((pat', term) : _) pat | pat == pat' = term
|
||||||
|
lookupTbl term (_ : tbl) pat = lookupTbl term tbl pat
|
||||||
|
|
||||||
|
subst x a (Arg n c (Path path)) = Arg n c (Path (map substP path))
|
||||||
|
where substP (Right (Var y)) | x==y = Right a
|
||||||
|
substP p = p
|
||||||
|
subst x a (con :^ ts) = con :^ map (subst x a) ts
|
||||||
|
subst x a (Rec rec) = Rec [ (l, subst x a t) | (l, t) <- rec ]
|
||||||
|
subst x a (t :. l) = subst x a t +. l
|
||||||
|
subst x a (Tbl tbl) = Tbl [ (subst x a p, subst x a t) | (p, t) <- tbl ]
|
||||||
|
subst x a (t :! s) = subst x a t +! subst x a s
|
||||||
|
subst x a (Variants ts) = variants $ map (subst x a) ts
|
||||||
|
subst x a (t1 :++ t2) = subst x a t1 ?++ subst x a t2
|
||||||
|
subst x a (Var y) | x==y = a
|
||||||
|
subst x a t = t
|
||||||
|
-}
|
||||||
|
|
||||||
(?++) :: Term c t -> Term c t -> Term c t
|
(?++) :: Term c t -> Term c t -> Term c t
|
||||||
Variants terms ?++ term = variants $ map (?++ term) terms
|
Variants terms ?++ term = variants $ map (?++ term) terms
|
||||||
term ?++ Variants terms = variants $ map (term ?++) terms
|
term ?++ Variants terms = variants $ map (term ?++) terms
|
||||||
@@ -213,10 +235,10 @@ instance (Print c, Print t) => Print (Term c t) where
|
|||||||
prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2
|
prt (t1 :++ t2) = prt t1 ++ "++" ++ prt t2
|
||||||
prt (Token t) = "'" ++ prt t ++ "'"
|
prt (Token t) = "'" ++ prt t ++ "'"
|
||||||
prt (Empty) = "[]"
|
prt (Empty) = "[]"
|
||||||
prt (Wildcard) = "_"
|
|
||||||
prt (term :. lbl) = prt term ++ "." ++ prt lbl
|
prt (term :. lbl) = prt term ++ "." ++ prt lbl
|
||||||
prt (term :! sel) = prt term ++ "!" ++ prt sel
|
prt (term :! sel) = prt term ++ "!" ++ prt sel
|
||||||
prt (Var var) = "?" ++ prt var
|
-- prt (Wildcard) = "_"
|
||||||
|
-- prt (Var var) = "?" ++ prt var
|
||||||
|
|
||||||
instance (Print c, Print t) => Print (Path c t) where
|
instance (Print c, Print t) => Print (Path c t) where
|
||||||
prt (Path path) = concatMap prtEither (reverse path)
|
prt (Path path) = concatMap prtEither (reverse path)
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:23:10 $
|
-- > CVS $Date: 2005/05/09 09:28:45 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.4 $
|
-- > CVS $Revision: 1.5 $
|
||||||
--
|
--
|
||||||
-- CFG parsing, parser information
|
-- CFG parsing, parser information
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -47,7 +47,7 @@ data CFPInfo c n t
|
|||||||
-- ^ DOES NOT WORK WITH EMPTY RULES!!!
|
-- ^ DOES NOT WORK WITH EMPTY RULES!!!
|
||||||
}
|
}
|
||||||
|
|
||||||
buildCFPInfo :: (Ord n, Ord c, Ord t) => CFGrammar c n t -> CFPInfo c n t
|
buildCFPInfo :: (Ord c, Ord n, Ord t) => CFGrammar c n t -> CFPInfo c n t
|
||||||
|
|
||||||
-- this is not permanent...
|
-- this is not permanent...
|
||||||
buildCFPInfo grammar = traceCalcFirst grammar $
|
buildCFPInfo grammar = traceCalcFirst grammar $
|
||||||
@@ -82,16 +82,17 @@ isCyclic _ = False
|
|||||||
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
-- pretty-printing of statistics
|
||||||
|
|
||||||
instance (Ord n, Ord c, Ord t) => Print (CFPInfo n c t) where
|
instance (Ord c, Ord n, Ord t) => Print (CFPInfo c n t) where
|
||||||
prt pI = "[ nr. tokens=" ++ sl grammarTokens ++
|
prt pI = "[ tokens=" ++ sl grammarTokens ++
|
||||||
"; nr. names=" ++ sla nameRules ++
|
"; names=" ++ sla nameRules ++
|
||||||
"; nr. tdCats=" ++ sla topdownRules ++
|
"; tdCats=" ++ sla topdownRules ++
|
||||||
"; nr. buCats=" ++ sla bottomupRules ++
|
"; buCats=" ++ sla bottomupRules ++
|
||||||
"; nr. elcCats=" ++ sla emptyLeftcornerRules ++
|
"; elcCats=" ++ sla emptyLeftcornerRules ++
|
||||||
"; nr. eCats=" ++ sla emptyCategories ++
|
"; eCats=" ++ sla emptyCategories ++
|
||||||
"; nr. cCats=" ++ sl cyclicCategories ++
|
-- "; cCats=" ++ sl cyclicCategories ++
|
||||||
"; nr. lctokCats=" ++ sla leftcornerTokens ++
|
-- "; lctokCats=" ++ sla leftcornerTokens ++
|
||||||
" ]"
|
" ]"
|
||||||
where sla f = show $ length $ aElems $ f pI
|
where sla f = show $ length $ aElems $ f pI
|
||||||
sl f = show $ length $ f pI
|
sl f = show $ length $ f pI
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:23:06 $
|
-- > CVS $Date: 2005/05/09 09:28:45 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.6 $
|
-- > CVS $Revision: 1.7 $
|
||||||
--
|
--
|
||||||
-- The main parsing module, parsing GFC grammars
|
-- The main parsing module, parsing GFC grammars
|
||||||
-- by translating to simpler formats, such as PMCFG and CFG
|
-- by translating to simpler formats, such as PMCFG and CFG
|
||||||
@@ -45,13 +45,15 @@ import qualified GF.Parsing.CFG as PC
|
|||||||
data PInfo = PInfo { mcfPInfo :: MCFPInfo,
|
data PInfo = PInfo { mcfPInfo :: MCFPInfo,
|
||||||
cfPInfo :: CFPInfo }
|
cfPInfo :: CFPInfo }
|
||||||
|
|
||||||
type MCFPInfo = MGrammar
|
type MCFPInfo = PM.MCFPInfo MCat Name MLabel Token
|
||||||
type CFPInfo = PC.CFPInfo CCat Name Token
|
type CFPInfo = PC.CFPInfo CCat Name Token
|
||||||
|
|
||||||
buildPInfo :: MGrammar -> CGrammar -> PInfo
|
buildPInfo :: MGrammar -> CGrammar -> PInfo
|
||||||
buildPInfo mcfg cfg = PInfo { mcfPInfo = mcfg,
|
buildPInfo mcfg cfg = PInfo { mcfPInfo = PM.buildMCFPInfo mcfg,
|
||||||
cfPInfo = PC.buildCFPInfo cfg }
|
cfPInfo = PC.buildCFPInfo cfg }
|
||||||
|
|
||||||
|
instance Print PInfo where
|
||||||
|
prt (PInfo m c) = prt m ++ "\n" ++ prt c
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- main parsing function
|
-- main parsing function
|
||||||
@@ -67,8 +69,9 @@ parse (prs:strategy) pinfo abs startCat inString =
|
|||||||
do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $
|
do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $
|
||||||
inputMany (map wordsCFTok inString)
|
inputMany (map wordsCFTok inString)
|
||||||
forests <- selectParser prs strategy pinfo startCat inTokens
|
forests <- selectParser prs strategy pinfo startCat inTokens
|
||||||
traceM "Parsing.GFC - nr. forests" (prt (length forests))
|
traceM "Parsing.GFC - nr. unfiltered forests" (prt (length forests))
|
||||||
let filteredForests = tracePrt "Parsing.GFC - nr. filtered forests" (prt . length) $
|
traceM "Parsing.GFC - nr. unfiltered trees" (prt (length (forests >>= forest2trees)))
|
||||||
|
let filteredForests = tracePrt "Parsing.GFC - nr. forests" (prt . length) $
|
||||||
forests >>= applyProfileToForest
|
forests >>= applyProfileToForest
|
||||||
-- compactFs = tracePrt "#compactForests" (prt . length) $
|
-- compactFs = tracePrt "#compactForests" (prt . length) $
|
||||||
-- tracePrt "compactForests" (prtBefore "\n") $
|
-- tracePrt "compactForests" (prtBefore "\n") $
|
||||||
@@ -100,13 +103,12 @@ selectParser prs strategy pinfo startCat inTokens | prs=='c'
|
|||||||
-- parsing via MCFG
|
-- parsing via MCFG
|
||||||
selectParser prs strategy pinfo startCat inTokens | prs=='m'
|
selectParser prs strategy pinfo startCat inTokens | prs=='m'
|
||||||
= do let startCats = tracePrt "Parsing.GFC - starting MCF categories" prt $
|
= do let startCats = tracePrt "Parsing.GFC - starting MCF categories" prt $
|
||||||
filter isStart $ nubsort [ c | G.Rule (G.Abs c _ _) _ <- mcfpi ]
|
filter isStart $ PM.grammarCats mcfpi
|
||||||
isStart cat = mcat2scat cat == cfCat2Ident startCat
|
isStart cat = mcat2scat cat == cfCat2Ident startCat
|
||||||
mcfpi = mcfPInfo pinfo
|
mcfpi = mcfPInfo pinfo
|
||||||
mcfParser <- PM.parseMCF strategy
|
mcfChart <- PM.parseMCF strategy mcfpi startCats inTokens
|
||||||
let mcfChart = tracePrt "Parsing.GFC - sz. MCF chart" (prt . length) $
|
traceM "Parsing.GFC - sz. MCF chart" (prt (length mcfChart))
|
||||||
mcfParser mcfpi startCats inTokens
|
let chart = tracePrt "Parsing.GFC - sz. chart" (prt . length . concat . map snd . aAssocs) $
|
||||||
chart = tracePrt "Parsing.GFC - sz. chart" (prt . map (length.snd) . aAssocs) $
|
|
||||||
G.abstract2chart mcfChart
|
G.abstract2chart mcfChart
|
||||||
finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $
|
finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $
|
||||||
[ PM.makeFinalEdge cat lbl (inputBounds inTokens) |
|
[ PM.makeFinalEdge cat lbl (inputBounds inTokens) |
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:23:07 $
|
-- > CVS $Date: 2005/05/09 09:28:45 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.3 $
|
-- > CVS $Revision: 1.4 $
|
||||||
--
|
--
|
||||||
-- MCFG parsing
|
-- MCFG parsing
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -23,20 +23,37 @@ import GF.Parsing.MCFG.PInfo
|
|||||||
|
|
||||||
import qualified GF.Parsing.MCFG.Naive as Naive
|
import qualified GF.Parsing.MCFG.Naive as Naive
|
||||||
import qualified GF.Parsing.MCFG.Active as Active
|
import qualified GF.Parsing.MCFG.Active as Active
|
||||||
import qualified GF.Parsing.MCFG.Range as Range (makeRange)
|
import qualified GF.Parsing.MCFG.Active2 as Active2
|
||||||
|
import qualified GF.Parsing.MCFG.Incremental as Incremental
|
||||||
|
import qualified GF.Parsing.MCFG.Incremental2 as Incremental2
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- parsing
|
-- parsing
|
||||||
|
|
||||||
parseMCF :: (Ord c, Ord n, Ord l, Ord t) => String -> Err (MCFParser c n l t)
|
-- parseMCF :: (Ord c, Ord n, Ord l, Ord t) => String -> Err (MCFParser c n l t)
|
||||||
parseMCF "n" = Ok $ Naive.parse
|
|
||||||
parseMCF "an" = Ok $ Active.parse "n"
|
parseMCF "n" pinfo starts toks = Ok $ Naive.parse pinfo starts toks
|
||||||
parseMCF "ab" = Ok $ Active.parse "b"
|
parseMCF "an" pinfo starts toks = Ok $ Active.parse "n" pinfo starts toks
|
||||||
parseMCF "at" = Ok $ Active.parse "t"
|
parseMCF "ab" pinfo starts toks = Ok $ Active.parse "b" pinfo starts toks
|
||||||
|
parseMCF "at" pinfo starts toks = Ok $ Active.parse "t" pinfo starts toks
|
||||||
|
parseMCF "i" pinfo starts toks = Ok $ Incremental.parse pinfo starts toks
|
||||||
|
|
||||||
|
parseMCF "an2" pinfo starts toks = Ok $ Active2.parse "n" pinfo starts toks
|
||||||
|
parseMCF "ab2" pinfo starts toks = Ok $ Active2.parse "b" pinfo starts toks
|
||||||
|
parseMCF "at2" pinfo starts toks = Ok $ Active2.parse "t" pinfo starts toks
|
||||||
|
parseMCF "i2" pinfo starts toks = Ok $ Incremental2.parse pinfo starts toks
|
||||||
|
|
||||||
|
parseMCF "rn" pinfo starts toks = Ok $ Naive.parseR (rrP pinfo toks) starts
|
||||||
|
parseMCF "ran" pinfo starts toks = Ok $ Active.parseR "n" (rrP pinfo toks) starts
|
||||||
|
parseMCF "rab" pinfo starts toks = Ok $ Active.parseR "b" (rrP pinfo toks) starts
|
||||||
|
parseMCF "rat" pinfo starts toks = Ok $ Active.parseR "t" (rrP pinfo toks) starts
|
||||||
|
parseMCF "ri" pinfo starts toks = Ok $ Incremental.parseR (rrP pinfo toks) starts ntoks
|
||||||
|
where ntoks = snd (inputBounds toks)
|
||||||
|
|
||||||
-- default parsers:
|
-- default parsers:
|
||||||
parseMCF "a" = parseMCF "an"
|
parseMCF "" pinfo starts toks = parseMCF "n" pinfo starts toks
|
||||||
-- error parser:
|
-- error parser:
|
||||||
parseMCF prs = Bad $ "Parser not defined: " ++ prs
|
parseMCF prs pinfo starts toks = Bad $ "Parser not defined: " ++ prs
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
rrP pi = rangeRestrictPInfo pi
|
||||||
|
|||||||
@@ -1,42 +1,245 @@
|
|||||||
|
|
||||||
module GF.Parsing.MCFG.Active (parse) where
|
module GF.Parsing.MCFG.Active (parse, parseR) where
|
||||||
|
|
||||||
import GF.Data.GeneralDeduction
|
import GF.Data.GeneralDeduction
|
||||||
|
import GF.Data.Assoc
|
||||||
|
|
||||||
import GF.Formalism.GCFG
|
import GF.Formalism.GCFG
|
||||||
import GF.Formalism.MCFG
|
import GF.Formalism.MCFG
|
||||||
import GF.Formalism.Utilities
|
import GF.Formalism.Utilities
|
||||||
|
|
||||||
import GF.Parsing.MCFG.Range
|
import GF.Parsing.MCFG.Range
|
||||||
import GF.Parsing.MCFG.PInfo
|
import GF.Parsing.MCFG.PInfo
|
||||||
|
|
||||||
import GF.System.Tracing
|
import GF.System.Tracing
|
||||||
|
|
||||||
import Control.Monad (guard)
|
import Control.Monad (guard)
|
||||||
|
|
||||||
|
import GF.Infra.Print
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- * parsing
|
-- * parsing
|
||||||
|
|
||||||
parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t
|
--parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t
|
||||||
parse strategy mcfg starts toks
|
parse strategy pinfo starts toks =
|
||||||
= [ Abs (cat, found) (zip rhs rrecs) fun |
|
trace2 "MCFG.Active - strategy" (if isBU strategy then "BU"
|
||||||
Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ]
|
else if isTD strategy then "TD" else "None") $
|
||||||
where chart = process strategy mcfg starts toks
|
[ Abs (cat, found) (zip rhs rrecs) fun |
|
||||||
|
Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ]
|
||||||
|
where chart = process strategy pinfo starts toks
|
||||||
|
|
||||||
|
--parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t
|
||||||
|
parseR strategy pinfo starts =
|
||||||
|
trace2 "MCFG.Active Range - strategy" (if isBU strategy then "BU"
|
||||||
|
else if isTD strategy then "TD" else "None") $
|
||||||
|
[ Abs (cat, found) (zip rhs rrecs) fun |
|
||||||
|
Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ]
|
||||||
|
where chart = processR strategy pinfo starts
|
||||||
|
|
||||||
process :: (Ord n, Ord c, Ord l, Ord t) =>
|
process :: (Ord n, Ord c, Ord l, Ord t) =>
|
||||||
String -> MCFGrammar c n l t -> [c] -> Input t -> AChart c n l
|
String -> MCFPInfo c n l t -> [c] -> Input t -> AChart c n l
|
||||||
process strategy mcfg starts toks
|
process strategy pinfo starts toks
|
||||||
= trace2 "MCFG.Active - strategy" (if isBU strategy then "BU"
|
= tracePrt "MCFG.Active - chart size" prtSizes $
|
||||||
else if isTD strategy then "TD" else "None") $
|
|
||||||
tracePrt "MCFG.Active - chart size" prtSizes $
|
|
||||||
buildChart keyof (complete : combine : convert : rules) axioms
|
buildChart keyof (complete : combine : convert : rules) axioms
|
||||||
where rules | isNil strategy = [scan]
|
where rules | isNil strategy = [scan]
|
||||||
| isBU strategy = [predictKilbury mcfg toks]
|
| isBU strategy = [scan, predictKilbury pinfo toks]
|
||||||
| isTD strategy = [predictEarley mcfg toks]
|
| isTD strategy = [scan, predictEarley pinfo toks]
|
||||||
axioms | isNil strategy = predict mcfg toks
|
axioms | isNil strategy = predict pinfo toks
|
||||||
| isBU strategy = terminal mcfg toks
|
| isBU strategy = terminal pinfo toks ++ initialScan pinfo toks
|
||||||
| isTD strategy = initial mcfg starts toks
|
| isTD strategy = initial pinfo starts toks
|
||||||
|
|
||||||
|
--processR :: (Ord n, Ord c, Ord l) =>
|
||||||
|
-- String -> MCFPInfo c n l Range -> [c] -> AChart c n l
|
||||||
|
processR strategy pinfo starts
|
||||||
|
= tracePrt "MCFG.Active Range - chart size" prtSizes $
|
||||||
|
-- tracePrt "MCFG.Active Range - final chart" prtChart $
|
||||||
|
buildChart keyof (complete : combine : convert : rules) axioms
|
||||||
|
where rules | isNil strategy = [scan]
|
||||||
|
| isBU strategy = [scan, predictKilburyR pinfo]
|
||||||
|
| isTD strategy = [scan, predictEarleyR pinfo]
|
||||||
|
axioms | isNil strategy = predictR pinfo
|
||||||
|
| isBU strategy = terminalR pinfo ++ initialScanR pinfo
|
||||||
|
| isTD strategy = initialR pinfo starts
|
||||||
|
|
||||||
isNil s = s=="n"
|
isNil s = s=="n"
|
||||||
isBU s = s=="b"
|
isBU s = s=="b"
|
||||||
isTD s = s=="t"
|
isTD s = s=="t"
|
||||||
|
|
||||||
|
-- used in prediction
|
||||||
|
emptyChildren :: Abstract c n -> [RangeRec l]
|
||||||
|
emptyChildren (Abs _ rhs _) = replicate (length rhs) []
|
||||||
|
|
||||||
|
makeMaxRange (Range (_, j)) = Range (j, j)
|
||||||
|
makeMaxRange EmptyRange = EmptyRange
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- * inference rules
|
||||||
|
|
||||||
|
-- completion
|
||||||
|
complete :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
complete _ (Active rule found rng (Lin l []) (lin:lins) recs) =
|
||||||
|
return $ Active rule (found ++ [(l, rng)]) EmptyRange lin lins recs
|
||||||
|
complete _ _ = []
|
||||||
|
|
||||||
|
-- scanning
|
||||||
|
scan :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
scan _ (Active rule found rng (Lin l (Tok rng':syms)) lins recs) =
|
||||||
|
do rng'' <- concatRange rng rng'
|
||||||
|
return $ Active rule found rng'' (Lin l syms) lins recs
|
||||||
|
scan _ _ = []
|
||||||
|
|
||||||
|
-- | Creates an Active Item every time it is possible to combine
|
||||||
|
-- an Active Item from the agenda with a Passive Item from the Chart
|
||||||
|
combine :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
combine chart item@(Active _ _ _ (Lin _ (Cat (c,_,_):_)) _ _) =
|
||||||
|
do Passive _c found <- chartLookup chart (Pass c)
|
||||||
|
combine2 chart found item
|
||||||
|
combine chart (Passive c found) =
|
||||||
|
do item <- chartLookup chart (Act c)
|
||||||
|
combine2 chart found item
|
||||||
|
combine _ _ = []
|
||||||
|
|
||||||
|
combine2 chart found' (Active rule found rng (Lin l (Cat (c, r, d):syms)) lins recs) =
|
||||||
|
do rng' <- projection r found'
|
||||||
|
rng'' <- concatRange rng rng'
|
||||||
|
recs' <- unifyRec recs d found'
|
||||||
|
return $ Active rule found rng'' (Lin l syms) lins recs'
|
||||||
|
|
||||||
|
-- | Active Items with nothing to find are converted to Final items,
|
||||||
|
-- which in turn are converted to Passive Items
|
||||||
|
convert :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
convert _ (Active rule found rng (Lin lbl []) [] recs) =
|
||||||
|
return $ Final rule (found ++ [(lbl,rng)]) recs
|
||||||
|
convert _ (Final (Abs cat _ _) found _) =
|
||||||
|
return $ Passive cat found
|
||||||
|
convert _ _ = []
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- Naive --
|
||||||
|
|
||||||
|
predict :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l]
|
||||||
|
predict pinfo toks = tracePrt "MCFG.Active (Naive) - predicted rules" (prt . length) $
|
||||||
|
do (Rule abs (Cnc _ _ lins)) <- rulesMatchingInput pinfo toks
|
||||||
|
(lin':lins') <- rangeRestRec toks lins
|
||||||
|
return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs)
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- NaiveR --
|
||||||
|
|
||||||
|
predictR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l]
|
||||||
|
predictR pinfo = tracePrt "MCFG.Active (Naive Range) - predicted rules" (prt . length) $
|
||||||
|
do (Rule abs (Cnc _ _ (lin:lins))) <- allRules pinfo
|
||||||
|
return $ Active abs [] EmptyRange lin lins (emptyChildren abs)
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- Earley --
|
||||||
|
|
||||||
|
-- anropas med alla startkategorier
|
||||||
|
initial :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> [c] -> Input t -> [Item c n l]
|
||||||
|
initial pinfo starts toks =
|
||||||
|
tracePrt "MCFG.Active (Earley) - initial rules" (prt . length) $
|
||||||
|
do cat <- starts
|
||||||
|
Rule abs (Cnc _ _ lins) <- topdownRules pinfo ? cat
|
||||||
|
lin' : lins' <- rangeRestRec toks lins
|
||||||
|
return $ Active abs [] (Range (0, 0)) lin' lins' (emptyChildren abs)
|
||||||
|
|
||||||
|
predictEarley :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t
|
||||||
|
-> AChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
predictEarley pinfo toks _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) =
|
||||||
|
topdownRules pinfo ? cat >>= predictEarley2 toks rng
|
||||||
|
predictEarley _ _ _ _ = []
|
||||||
|
|
||||||
|
predictEarley2 :: (Ord c, Ord n, Ord l, Ord t) => Input t -> Range -> MCFRule c n l t -> [Item c n l]
|
||||||
|
predictEarley2 toks _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) =
|
||||||
|
do lins' <- rangeRestRec toks lins
|
||||||
|
return $ Final abs (makeRangeRec lins') []
|
||||||
|
predictEarley2 toks rng (Rule abs (Cnc _ _ lins)) =
|
||||||
|
do lin' : lins' <- rangeRestRec toks lins
|
||||||
|
return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs)
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- Earley Range --
|
||||||
|
|
||||||
|
initialR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [c] -> [Item c n l]
|
||||||
|
initialR pinfo starts =
|
||||||
|
tracePrt "MCFG.Active (Earley Range) - initial rules" (prt . length) $
|
||||||
|
do cat <- starts
|
||||||
|
Rule abs (Cnc _ _ (lin : lins)) <- topdownRules pinfo ? cat
|
||||||
|
return $ Active abs [] (Range (0, 0)) lin lins (emptyChildren abs)
|
||||||
|
|
||||||
|
predictEarleyR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range
|
||||||
|
-> AChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
predictEarleyR pinfo _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) =
|
||||||
|
topdownRules pinfo ? cat >>= predictEarleyR2 rng
|
||||||
|
predictEarleyR _ _ _ = []
|
||||||
|
|
||||||
|
predictEarleyR2 :: (Ord c, Ord n, Ord l) => Range -> MCFRule c n l Range -> [Item c n l]
|
||||||
|
predictEarleyR2 _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) =
|
||||||
|
return $ Final abs (makeRangeRec lins) []
|
||||||
|
predictEarleyR2 rng (Rule abs (Cnc _ _ (lin : lins))) =
|
||||||
|
return $ Active abs [] EmptyRange lin lins (emptyChildren abs)
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- Kilbury --
|
||||||
|
|
||||||
|
terminal :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l]
|
||||||
|
terminal pinfo toks =
|
||||||
|
tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $
|
||||||
|
do Rule abs (Cnc _ _ lins) <- emptyRules pinfo
|
||||||
|
lins' <- rangeRestRec toks lins
|
||||||
|
return $ Final abs (makeRangeRec lins') []
|
||||||
|
|
||||||
|
initialScan :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l]
|
||||||
|
initialScan pinfo toks =
|
||||||
|
tracePrt "MCFG.Active (Kilbury) - initial scanned rules" (prt . length) $
|
||||||
|
do tok <- aElems (inputToken toks)
|
||||||
|
Rule abs (Cnc _ _ lins) <- leftcornerTokens pinfo ? tok
|
||||||
|
lin' : lins' <- rangeRestRec toks lins
|
||||||
|
return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs)
|
||||||
|
|
||||||
|
predictKilbury :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t
|
||||||
|
-> AChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
predictKilbury pinfo toks _ (Passive cat found) =
|
||||||
|
do Rule abs (Cnc _ _ (Lin l (Cat (_,r,i):syms) : lins)) <- leftcornerCats pinfo ? cat
|
||||||
|
lin' : lins' <- rangeRestRec toks (Lin l syms : lins)
|
||||||
|
rng <- projection r found
|
||||||
|
children <- unifyRec (emptyChildren abs) i found
|
||||||
|
return $ Active abs [] rng lin' lins' children
|
||||||
|
predictKilbury _ _ _ _ = []
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- KilburyR --
|
||||||
|
|
||||||
|
terminalR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l]
|
||||||
|
terminalR pinfo =
|
||||||
|
tracePrt "MCFG.Active (Kilbury Range) - initial terminal rules" (prt . length) $
|
||||||
|
do Rule abs (Cnc _ _ lins) <- emptyRules pinfo
|
||||||
|
return $ Final abs (makeRangeRec lins) []
|
||||||
|
|
||||||
|
initialScanR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l]
|
||||||
|
initialScanR pinfo =
|
||||||
|
tracePrt "MCFG.Active (Kilbury Range) - initial scanned rules" (prt . length) $
|
||||||
|
do Rule abs (Cnc _ _ (lin : lins)) <- concatMap snd (aAssocs (leftcornerTokens pinfo))
|
||||||
|
return $ Active abs [] EmptyRange lin lins (emptyChildren abs)
|
||||||
|
|
||||||
|
predictKilburyR :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range
|
||||||
|
-> AChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
predictKilburyR pinfo _ (Passive cat found) =
|
||||||
|
do Rule abs (Cnc _ _ (Lin l (Cat (_,r,i):syms) : lins)) <- leftcornerCats pinfo ? cat
|
||||||
|
rng <- projection r found
|
||||||
|
children <- unifyRec (emptyChildren abs) i found
|
||||||
|
return $ Active abs [] rng (Lin l syms) lins children
|
||||||
|
predictKilburyR _ _ _ = []
|
||||||
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- * type definitions
|
-- * type definitions
|
||||||
|
|
||||||
@@ -65,11 +268,10 @@ keyof (Final _ _ _) = Fin
|
|||||||
keyof (Passive cat _) = Pass cat
|
keyof (Passive cat _) = Pass cat
|
||||||
keyof _ = Useless
|
keyof _ = Useless
|
||||||
|
|
||||||
-- to be used in prediction
|
|
||||||
emptyChildren :: Abstract c n -> [RangeRec l]
|
|
||||||
emptyChildren (Abs _ rhs _) = replicate (length rhs) []
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
-- for tracing purposes
|
-- for tracing purposes
|
||||||
|
|
||||||
prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++
|
prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++
|
||||||
", passive=" ++ show (sum [length (chartLookup chart k) |
|
", passive=" ++ show (sum [length (chartLookup chart k) |
|
||||||
k@(Pass _) <- chartKeys chart ]) ++
|
k@(Pass _) <- chartKeys chart ]) ++
|
||||||
@@ -77,110 +279,26 @@ prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++
|
|||||||
k@(Act _) <- chartKeys chart ]) ++
|
k@(Act _) <- chartKeys chart ]) ++
|
||||||
", useless=" ++ show (length (chartLookup chart Useless))
|
", useless=" ++ show (length (chartLookup chart Useless))
|
||||||
|
|
||||||
|
prtChart chart = concat [ "\n*** KEY: " ++ prt k ++
|
||||||
|
prtBefore "\n " (chartLookup chart k) |
|
||||||
|
k <- chartKeys chart ]
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
prtFinals chart = prtBefore "\n " (chartLookup chart Fin)
|
||||||
-- * inference rules
|
|
||||||
|
|
||||||
-- completion
|
instance (Print c, Print n, Print l) => Print (Item c n l) where
|
||||||
complete :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l]
|
prt (Active abs found rng lin tofind children) =
|
||||||
complete _ (Active rule found rng (Lin l []) (lin:lins) recs) =
|
"? " ++ prt abs ++ ";\n\t" ++
|
||||||
return $ Active rule (found ++ [(l, rng)]) EmptyRange lin lins recs
|
"{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++
|
||||||
complete _ _ = []
|
prt lin ++ " {" ++ prtSep " " tofind ++ "}" ++
|
||||||
|
( if null children then ";" else ";\n\t" ++
|
||||||
|
"{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" )
|
||||||
|
prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}"
|
||||||
|
prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++
|
||||||
|
( if null rrs then ";" else ";\n\t" ++
|
||||||
|
"{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" )
|
||||||
|
|
||||||
-- scanning
|
instance Print c => Print (AKey c) where
|
||||||
scan :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l]
|
prt (Act c) = "Active " ++ prt c
|
||||||
scan _ (Active rule found rng (Lin l (Tok rng':syms)) lins recs) =
|
prt (Pass c) = "Passive " ++ prt c
|
||||||
do rng'' <- concatRange rng rng'
|
prt (Fin) = "Final"
|
||||||
return $ Active rule found rng'' (Lin l syms) lins recs
|
prt (Useless) = "Useless"
|
||||||
scan _ _ = []
|
|
||||||
|
|
||||||
-- | Creates an Active Item every time it is possible to combine
|
|
||||||
-- an Active Item from the agenda with a Passive Item from the Chart
|
|
||||||
combine :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l]
|
|
||||||
combine chart (Active rule found rng (Lin l (Cat (c, r, d):syms)) lins recs) =
|
|
||||||
do Passive _c found' <- chartLookup chart (Pass c)
|
|
||||||
rng' <- projection r found'
|
|
||||||
rng'' <- concatRange rng rng'
|
|
||||||
guard $ subsumes (recs !! d) found'
|
|
||||||
return $ Active rule found rng'' (Lin l syms) lins (replaceRec recs d found')
|
|
||||||
combine chart (Passive c found) =
|
|
||||||
do Active rule found' rng' (Lin l ((Cat (_c, r, d)):syms)) lins recs'
|
|
||||||
<- chartLookup chart (Act c)
|
|
||||||
rng'' <- projection r found
|
|
||||||
rng <- concatRange rng' rng''
|
|
||||||
guard $ subsumes (recs' !! d) found
|
|
||||||
return $ Active rule found' rng (Lin l syms) lins (replaceRec recs' d found)
|
|
||||||
combine _ _ = []
|
|
||||||
|
|
||||||
-- | Active Items with nothing to find are converted to Final items,
|
|
||||||
-- which in turn are converted to Passive Items
|
|
||||||
convert :: (Ord c, Ord n, Ord l) => AChart c n l -> Item c n l -> [Item c n l]
|
|
||||||
convert _ (Active rule found rng (Lin lbl []) [] recs) =
|
|
||||||
return $ Final rule (found ++ [(lbl,rng)]) recs
|
|
||||||
convert _ (Final (Abs cat _ _) found _) =
|
|
||||||
return $ Passive cat found
|
|
||||||
convert _ _ = []
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
|
||||||
-- Naive --
|
|
||||||
|
|
||||||
-- | Creates an Active Item of every Rule in the Grammar to give the initial Agenda
|
|
||||||
predict :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> Input t -> [Item c n l]
|
|
||||||
predict grammar toks =
|
|
||||||
do Rule abs (Cnc _ _ lins) <- grammar
|
|
||||||
(lin':lins') <- rangeRestRec toks lins
|
|
||||||
return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs)
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
|
||||||
-- Earley --
|
|
||||||
|
|
||||||
-- anropas med alla startkategorier
|
|
||||||
initial :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> [c] -> Input t -> [Item c n l]
|
|
||||||
initial mcfg starts toks =
|
|
||||||
do Rule abs@(Abs cat _ _) (Cnc _ _ lins) <- mcfg
|
|
||||||
guard $ cat `elem` starts
|
|
||||||
lin' : lins' <- rangeRestRec toks lins
|
|
||||||
return $ Active abs [] (Range (0, 0)) lin' lins' (emptyChildren abs)
|
|
||||||
|
|
||||||
-- earley prediction
|
|
||||||
predictEarley :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> Input t
|
|
||||||
-> AChart c n l -> Item c n l -> [Item c n l]
|
|
||||||
predictEarley mcfg toks _ (Active _ _ rng (Lin _ (Cat (cat,_,_):_)) _ _) =
|
|
||||||
do rule@(Rule (Abs cat' _ _) _) <- mcfg
|
|
||||||
guard $ cat == cat'
|
|
||||||
predEar toks rng rule
|
|
||||||
predictEarley _ _ _ _ = []
|
|
||||||
|
|
||||||
predEar :: (Ord c, Ord n, Ord l, Ord t) =>
|
|
||||||
Input t -> Range -> MCFRule c n l t -> [Item c n l]
|
|
||||||
predEar toks _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) =
|
|
||||||
do lins' <- rangeRestRec toks lins
|
|
||||||
return $ Final abs (makeRangeRec lins') []
|
|
||||||
predEar toks rng (Rule abs (Cnc _ _ lins)) =
|
|
||||||
do lin' : lins' <- rangeRestRec toks lins
|
|
||||||
return $ Active abs [] (makeMaxRange rng) lin' lins' (emptyChildren abs)
|
|
||||||
|
|
||||||
makeMaxRange (Range (_, j)) = Range (j, j)
|
|
||||||
makeMaxRange EmptyRange = EmptyRange
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
|
||||||
-- Kilbury --
|
|
||||||
|
|
||||||
terminal :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> Input t -> [Item c n l]
|
|
||||||
terminal mcfg toks =
|
|
||||||
do Rule abs@(Abs _ [] _) (Cnc _ _ lins) <- mcfg
|
|
||||||
lins' <- rangeRestRec toks lins
|
|
||||||
return $ Final abs (makeRangeRec lins') []
|
|
||||||
|
|
||||||
-- kilbury prediction
|
|
||||||
predictKilbury :: (Ord c, Ord n, Ord l, Ord t) =>
|
|
||||||
MCFGrammar c n l t -> Input t
|
|
||||||
-> AChart c n l -> Item c n l -> [Item c n l]
|
|
||||||
predictKilbury mcfg toks _ (Passive cat found) =
|
|
||||||
do Rule abs@(Abs _ rhs _) (Cnc _ _ (Lin l (Cat (cat', r, i):syms) : lins)) <- mcfg
|
|
||||||
guard $ cat == cat'
|
|
||||||
lin' : lins' <- rangeRestRec toks (Lin l syms : lins)
|
|
||||||
rng <- projection r found
|
|
||||||
let children = replaceRec (emptyChildren abs) i found
|
|
||||||
return $ Active abs [] rng lin' lins' children
|
|
||||||
predictKilbury _ _ _ _ = []
|
|
||||||
|
|||||||
226
src/GF/Parsing/MCFG/Active2.hs
Normal file
226
src/GF/Parsing/MCFG/Active2.hs
Normal file
@@ -0,0 +1,226 @@
|
|||||||
|
|
||||||
|
module GF.Parsing.MCFG.Active2 (parse) where
|
||||||
|
|
||||||
|
import GF.Data.GeneralDeduction
|
||||||
|
import GF.Data.Assoc
|
||||||
|
|
||||||
|
import GF.Formalism.GCFG
|
||||||
|
import GF.Formalism.MCFG
|
||||||
|
import GF.Formalism.Utilities
|
||||||
|
|
||||||
|
import GF.Parsing.MCFG.Range
|
||||||
|
import GF.Parsing.MCFG.PInfo
|
||||||
|
|
||||||
|
import GF.System.Tracing
|
||||||
|
|
||||||
|
import Control.Monad (guard)
|
||||||
|
|
||||||
|
import GF.Infra.Print
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- * parsing
|
||||||
|
|
||||||
|
--parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t
|
||||||
|
parse strategy pinfo starts toks =
|
||||||
|
trace2 "MCFG.Active 2 - strategy" (if isBU strategy then "BU"
|
||||||
|
else if isTD strategy then "TD" else "None") $
|
||||||
|
[ Abs (cat, found) (zip rhs rrecs) fun |
|
||||||
|
Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ]
|
||||||
|
where chart = process strategy pinfo starts toks
|
||||||
|
|
||||||
|
process :: (Ord n, Ord c, Ord l, Ord t) =>
|
||||||
|
String -> MCFPInfo c n l t -> [c] -> Input t -> AChart c n l t
|
||||||
|
process strategy pinfo starts toks
|
||||||
|
= tracePrt "MCFG.Active - chart size" prtSizes $
|
||||||
|
buildChart keyof (complete : combine : convert : rules) axioms
|
||||||
|
where rules | isNil strategy = [scan toks]
|
||||||
|
| isBU strategy = [scan toks, predictKilbury pinfo toks]
|
||||||
|
| isTD strategy = [scan toks, predictEarley pinfo toks]
|
||||||
|
axioms | isNil strategy = predict pinfo toks
|
||||||
|
| isBU strategy = terminal pinfo toks ++ initialScan pinfo toks
|
||||||
|
| isTD strategy = initial pinfo starts toks
|
||||||
|
|
||||||
|
isNil s = s=="n"
|
||||||
|
isBU s = s=="b"
|
||||||
|
isTD s = s=="t"
|
||||||
|
|
||||||
|
-- used in prediction
|
||||||
|
emptyChildren :: Abstract c n -> [RangeRec l]
|
||||||
|
emptyChildren (Abs _ rhs _) = replicate (length rhs) []
|
||||||
|
|
||||||
|
makeMaxRange (Range (_, j)) = Range (j, j)
|
||||||
|
makeMaxRange EmptyRange = EmptyRange
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- * inference rules
|
||||||
|
|
||||||
|
-- completion
|
||||||
|
complete :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t]
|
||||||
|
complete _ (Active rule found rng (Lin l []) (lin:lins) recs) =
|
||||||
|
return $ Active rule (found ++ [(l, rng)]) EmptyRange lin lins recs
|
||||||
|
complete _ _ = []
|
||||||
|
|
||||||
|
-- scanning
|
||||||
|
--scan :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t]
|
||||||
|
scan inp _ (Active rule found rng (Lin l (Tok tok:syms)) lins recs) =
|
||||||
|
do rng' <- map makeRange (inputToken inp ? tok)
|
||||||
|
rng'' <- concatRange rng rng'
|
||||||
|
return $ Active rule found rng'' (Lin l syms) lins recs
|
||||||
|
scan _ _ _ = []
|
||||||
|
|
||||||
|
-- | Creates an Active Item every time it is possible to combine
|
||||||
|
-- an Active Item from the agenda with a Passive Item from the Chart
|
||||||
|
combine :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t]
|
||||||
|
combine chart item@(Active _ _ _ (Lin _ (Cat (c,_,_):_)) _ _) =
|
||||||
|
do Passive _c found <- chartLookup chart (Pass c)
|
||||||
|
combine2 chart found item
|
||||||
|
combine chart (Passive c found) =
|
||||||
|
do item <- chartLookup chart (Act c)
|
||||||
|
combine2 chart found item
|
||||||
|
combine _ _ = []
|
||||||
|
|
||||||
|
combine2 chart found' (Active rule found rng (Lin l (Cat (c, r, d):syms)) lins recs) =
|
||||||
|
do rng' <- projection r found'
|
||||||
|
rng'' <- concatRange rng rng'
|
||||||
|
recs' <- unifyRec recs d found'
|
||||||
|
return $ Active rule found rng'' (Lin l syms) lins recs'
|
||||||
|
|
||||||
|
-- | Active Items with nothing to find are converted to Final items,
|
||||||
|
-- which in turn are converted to Passive Items
|
||||||
|
convert :: (Ord c, Ord n, Ord l, Ord t) => AChart c n l t -> Item c n l t -> [Item c n l t]
|
||||||
|
convert _ (Active rule found rng (Lin lbl []) [] recs) =
|
||||||
|
return $ Final rule (found ++ [(lbl,rng)]) recs
|
||||||
|
convert _ (Final (Abs cat _ _) found _) =
|
||||||
|
return $ Passive cat found
|
||||||
|
convert _ _ = []
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- Naive --
|
||||||
|
|
||||||
|
predict :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l t]
|
||||||
|
predict pinfo toks = tracePrt "MCFG.Active (Naive) - predicted rules" (prt . length) $
|
||||||
|
do Rule abs (Cnc _ _ (lin:lins)) <- rulesMatchingInput pinfo toks
|
||||||
|
return $ Active abs [] EmptyRange lin lins (emptyChildren abs)
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- Earley --
|
||||||
|
|
||||||
|
-- anropas med alla startkategorier
|
||||||
|
initial :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> [c] -> Input t -> [Item c n l t]
|
||||||
|
initial pinfo starts toks =
|
||||||
|
tracePrt "MCFG.Active (Earley) - initial rules" (prt . length) $
|
||||||
|
do cat <- starts
|
||||||
|
Rule abs (Cnc _ _ (lin:lins)) <- topdownRules pinfo ? cat
|
||||||
|
return $ Active abs [] (Range (0, 0)) lin lins (emptyChildren abs)
|
||||||
|
|
||||||
|
predictEarley :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t
|
||||||
|
-> AChart c n l t -> Item c n l t -> [Item c n l t]
|
||||||
|
predictEarley pinfo toks _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) =
|
||||||
|
topdownRules pinfo ? cat >>= predictEarley2 toks rng
|
||||||
|
predictEarley _ _ _ _ = []
|
||||||
|
|
||||||
|
predictEarley2 :: (Ord c, Ord n, Ord l, Ord t) => Input t -> Range -> MCFRule c n l t -> [Item c n l t]
|
||||||
|
predictEarley2 toks _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) =
|
||||||
|
do lins' <- rangeRestRec toks lins
|
||||||
|
return $ Final abs (makeRangeRec lins') []
|
||||||
|
predictEarley2 toks rng (Rule abs (Cnc _ _ (lin:lins))) =
|
||||||
|
return $ Active abs [] EmptyRange lin lins (emptyChildren abs)
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- Kilbury --
|
||||||
|
|
||||||
|
terminal :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l t]
|
||||||
|
terminal pinfo toks =
|
||||||
|
tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $
|
||||||
|
do Rule abs (Cnc _ _ lins) <- emptyRules pinfo
|
||||||
|
lins' <- rangeRestRec toks lins
|
||||||
|
return $ Final abs (makeRangeRec lins') []
|
||||||
|
|
||||||
|
initialScan :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l t]
|
||||||
|
initialScan pinfo toks =
|
||||||
|
tracePrt "MCFG.Active (Kilbury) - initial scanned rules" (prt . length) $
|
||||||
|
do tok <- aElems (inputToken toks)
|
||||||
|
Rule abs (Cnc _ _ (lin:lins)) <- leftcornerTokens pinfo ? tok
|
||||||
|
return $ Active abs [] EmptyRange lin lins (emptyChildren abs)
|
||||||
|
|
||||||
|
predictKilbury :: (Ord c, Ord n, Ord l, Ord t) => MCFPInfo c n l t -> Input t
|
||||||
|
-> AChart c n l t -> Item c n l t -> [Item c n l t]
|
||||||
|
predictKilbury pinfo toks _ (Passive cat found) =
|
||||||
|
do Rule abs (Cnc _ _ (Lin l (Cat (_,r,i):syms) : lins)) <- leftcornerCats pinfo ? cat
|
||||||
|
rng <- projection r found
|
||||||
|
children <- unifyRec (emptyChildren abs) i found
|
||||||
|
return $ Active abs [] rng (Lin l syms) lins children
|
||||||
|
predictKilbury _ _ _ _ = []
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- * type definitions
|
||||||
|
|
||||||
|
type AChart c n l t = ParseChart (Item c n l t) (AKey c t)
|
||||||
|
|
||||||
|
data Item c n l t = Active (Abstract c n)
|
||||||
|
(RangeRec l)
|
||||||
|
Range
|
||||||
|
(Lin c l t)
|
||||||
|
(LinRec c l t)
|
||||||
|
[RangeRec l]
|
||||||
|
| Final (Abstract c n) (RangeRec l) [RangeRec l]
|
||||||
|
| Passive c (RangeRec l)
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
data AKey c t = Act c
|
||||||
|
| ActTok t
|
||||||
|
| Pass c
|
||||||
|
| Useless
|
||||||
|
| Fin
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
|
||||||
|
keyof :: Item c n l t -> AKey c t
|
||||||
|
keyof (Active _ _ _ (Lin _ (Cat (next, _, _):_)) _ _) = Act next
|
||||||
|
keyof (Active _ _ _ (Lin _ (Tok tok:_)) _ _) = ActTok tok
|
||||||
|
keyof (Final _ _ _) = Fin
|
||||||
|
keyof (Passive cat _) = Pass cat
|
||||||
|
keyof _ = Useless
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- for tracing purposes
|
||||||
|
|
||||||
|
prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++
|
||||||
|
", passive=" ++ show (sum [length (chartLookup chart k) |
|
||||||
|
k@(Pass _) <- chartKeys chart ]) ++
|
||||||
|
", active=" ++ show (sum [length (chartLookup chart k) |
|
||||||
|
k@(Act _) <- chartKeys chart ]) ++
|
||||||
|
", active-tok=" ++ show (sum [length (chartLookup chart k) |
|
||||||
|
k@(ActTok _) <- chartKeys chart ]) ++
|
||||||
|
", useless=" ++ show (length (chartLookup chart Useless))
|
||||||
|
|
||||||
|
prtChart chart = concat [ "\n*** KEY: " ++ prt k ++
|
||||||
|
prtBefore "\n " (chartLookup chart k) |
|
||||||
|
k <- chartKeys chart ]
|
||||||
|
|
||||||
|
prtFinals chart = prtBefore "\n " (chartLookup chart Fin)
|
||||||
|
|
||||||
|
instance (Print c, Print n, Print l, Print t) => Print (Item c n l t) where
|
||||||
|
prt (Active abs found rng lin tofind children) =
|
||||||
|
"? " ++ prt abs ++ ";\n\t" ++
|
||||||
|
"{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++
|
||||||
|
prt lin ++ " {" ++ prtSep " " tofind ++ "}" ++
|
||||||
|
( if null children then ";" else ";\n\t" ++
|
||||||
|
"{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" )
|
||||||
|
prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}"
|
||||||
|
prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++
|
||||||
|
( if null rrs then ";" else ";\n\t" ++
|
||||||
|
"{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" )
|
||||||
|
|
||||||
|
instance (Print c, Print t) => Print (AKey c t) where
|
||||||
|
prt (Act c) = "Active " ++ prt c
|
||||||
|
prt (ActTok t) = "Active-Tok " ++ prt t
|
||||||
|
prt (Pass c) = "Passive " ++ prt c
|
||||||
|
prt (Fin) = "Final"
|
||||||
|
prt (Useless) = "Useless"
|
||||||
@@ -1,123 +1,163 @@
|
|||||||
{-- Module --------------------------------------------------------------------
|
|
||||||
Filename: IncrementalParse.hs
|
|
||||||
Author: Håkan Burden
|
|
||||||
Time-stamp: <2005-04-18, 15:07>
|
|
||||||
|
|
||||||
Description: An agenda-driven implementation of the incremental algorithm 4.6
|
module GF.Parsing.MCFG.Incremental (parse, parseR) where
|
||||||
that handles erasing and suppressing MCFG.
|
|
||||||
As described in Ljunglöf (2004)
|
|
||||||
------------------------------------------------------------------------------}
|
|
||||||
|
|
||||||
module GF.Parsing.MCFG.Incremental where
|
|
||||||
|
|
||||||
|
|
||||||
-- Haskell
|
|
||||||
import Data.List
|
import Data.List
|
||||||
|
import Control.Monad (guard)
|
||||||
|
|
||||||
|
import GF.Data.Utilities (select)
|
||||||
|
import GF.Data.GeneralDeduction
|
||||||
|
|
||||||
|
import GF.Formalism.GCFG
|
||||||
|
import GF.Formalism.MCFG
|
||||||
|
import GF.Formalism.Utilities
|
||||||
|
|
||||||
-- GF modules
|
|
||||||
import Examples
|
|
||||||
import GF.OldParsing.GeneralChart
|
|
||||||
import GF.OldParsing.MCFGrammar
|
|
||||||
import MCFParser
|
|
||||||
import Parser
|
|
||||||
import GF.Parsing.MCFG.Range
|
import GF.Parsing.MCFG.Range
|
||||||
import Nondet
|
import GF.Parsing.MCFG.PInfo
|
||||||
|
|
||||||
|
import GF.System.Tracing
|
||||||
|
import GF.Infra.Print
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- parsing
|
||||||
|
|
||||||
|
parse :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t
|
||||||
|
parse pinfo starts toks =
|
||||||
|
[ Abs (cat, found) (zip rhs rrecs) fun |
|
||||||
|
Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ]
|
||||||
|
where chart = process pinfo toks ntoks
|
||||||
|
ntoks = snd (inputBounds toks)
|
||||||
|
|
||||||
|
-- parseR :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t
|
||||||
|
parseR pinfo starts ntoks =
|
||||||
|
[ Abs (cat, found) (zip rhs rrecs) fun |
|
||||||
|
Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ]
|
||||||
|
where chart = processR pinfo ntoks
|
||||||
|
|
||||||
|
process :: (Ord n, Ord c, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> Int -> IChart c n l
|
||||||
|
process pinfo toks ntoks
|
||||||
|
= tracePrt "MCFG.Incremental - chart size" prtSizes $
|
||||||
|
buildChart keyof [complete ntoks, scan, combine, convert] (predict pinfo toks ntoks)
|
||||||
|
|
||||||
|
processR :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> Int -> IChart c n l
|
||||||
|
processR pinfo ntoks
|
||||||
|
= tracePrt "MCFG.Incremental Range - chart size" prtSizes $
|
||||||
|
buildChart keyof [complete ntoks, scan, combine, convert] (predictR pinfo ntoks)
|
||||||
|
|
||||||
|
complete :: (Ord n, Ord c, Ord l) => Int -> IChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
complete ntoks _ (Active rule found rng (Lin l []) lins recs) =
|
||||||
|
do (lin, lins') <- select lins
|
||||||
|
k <- [minRange rng .. ntoks]
|
||||||
|
return $ Active rule (found ++ [(l, rng)]) (Range (k,k)) lin lins' recs
|
||||||
|
complete _ _ _ = []
|
||||||
|
|
||||||
|
|
||||||
{-- Datatypes -----------------------------------------------------------------
|
predict :: (Ord n, Ord c, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> Int -> [Item c n l]
|
||||||
IChart: A RedBlackMap with Items and Keys
|
predict pinfo toks n =
|
||||||
Item : One kind of Item since the Passive Items not necessarily need to be
|
tracePrt "MCFG.Incremental - predicted rules" (prt . length) $
|
||||||
saturated iow, they can still have rows to recognize.
|
do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- rulesMatchingInput pinfo toks
|
||||||
IKey :
|
let daughters = replicate (length rhs) []
|
||||||
------------------------------------------------------------------------------}
|
lins' <- rangeRestRec toks lins
|
||||||
|
(lin', lins'') <- select lins'
|
||||||
|
k <- [0..n]
|
||||||
|
return $ Active abs [] (Range (k,k)) lin' lins'' daughters
|
||||||
|
|
||||||
type IChart n c l = ParseChart (Item n c l) (IKey c l)
|
|
||||||
|
|
||||||
data Item n c l = Active (AbstractRule n c)
|
predictR :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> Int -> [Item c n l]
|
||||||
|
predictR pinfo n =
|
||||||
|
tracePrt "MCFG.Incremental Range - predicted rules" (prt . length) $
|
||||||
|
do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- allRules pinfo
|
||||||
|
let daughters = replicate (length rhs) []
|
||||||
|
(lin, lins') <- select lins
|
||||||
|
k <- [0..n]
|
||||||
|
return $ Active abs [] (Range (k,k)) lin lins' daughters
|
||||||
|
|
||||||
|
|
||||||
|
scan :: (Ord n, Ord c, Ord l) => IChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
scan _ (Active abs found rng (Lin l (Tok rng':syms)) lins recs) =
|
||||||
|
do rng'' <- concatRange rng rng'
|
||||||
|
return $ Active abs found rng'' (Lin l syms) lins recs
|
||||||
|
scan _ _ = []
|
||||||
|
|
||||||
|
|
||||||
|
combine :: (Ord n, Ord c, Ord l) => IChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
combine chart active@(Active _ _ rng (Lin _ (Cat (c,l,_):_)) _ _) =
|
||||||
|
do passive <- chartLookup chart (Pass c l (maxRange rng))
|
||||||
|
combine2 active passive
|
||||||
|
combine chart passive@(Active (Abs c _ _) _ rng (Lin l []) _ _) =
|
||||||
|
do active <- chartLookup chart (Act c l (minRange rng))
|
||||||
|
combine2 active passive
|
||||||
|
combine _ _ = []
|
||||||
|
|
||||||
|
combine2 (Active abs found rng (Lin l (Cat (c,l',d):syms)) lins recs)
|
||||||
|
(Active _ found' rng' _ _ _)
|
||||||
|
= do rng'' <- concatRange rng rng'
|
||||||
|
recs' <- unifyRec recs d found''
|
||||||
|
return $ Active abs found rng'' (Lin l syms) lins recs'
|
||||||
|
where found'' = found' ++ [(l',rng')]
|
||||||
|
|
||||||
|
|
||||||
|
convert _ (Active rule found rng (Lin lbl []) [] recs) =
|
||||||
|
return $ Final rule (found ++ [(lbl,rng)]) recs
|
||||||
|
convert _ _ = []
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- type definitions
|
||||||
|
|
||||||
|
type IChart c n l = ParseChart (Item c n l) (IKey c l)
|
||||||
|
|
||||||
|
data Item c n l = Active (Abstract c n)
|
||||||
(RangeRec l)
|
(RangeRec l)
|
||||||
Range
|
Range
|
||||||
(Lin c l Range)
|
(Lin c l Range)
|
||||||
(LinRec c l Range)
|
(LinRec c l Range)
|
||||||
[RangeRec l]
|
[RangeRec l]
|
||||||
-- | Passive (AbstractRule n c)
|
| Final (Abstract c n) (RangeRec l) [RangeRec l]
|
||||||
-- (RangeRec l)
|
-- | Passive c (RangeRec l)
|
||||||
-- [RangeRec l]
|
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
data IKey c l = Act c l Int
|
data IKey c l = Act c l Int
|
||||||
-- | ActE l
|
|
||||||
| Pass c l Int
|
| Pass c l Int
|
||||||
-- | Pred l
|
|
||||||
| Useless
|
| Useless
|
||||||
|
| Fin
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
keyof :: Item n c l -> IKey c l
|
keyof :: Item c n l -> IKey c l
|
||||||
keyof (Active _ _ (Range (_,j)) (Lin _ ((Cat (next,lbl,_)):_)) _ _)
|
keyof (Active _ _ rng (Lin _ (Cat (next,lbl,_):_)) _ _)
|
||||||
= Act next lbl j
|
= Act next lbl (maxRange rng)
|
||||||
keyof (Active (_, cat, _) found (Range (i,_)) (Lin lbl []) _ _)
|
keyof (Active (Abs cat _ _) found rng (Lin lbl []) _ _)
|
||||||
= Pass cat lbl i
|
= Pass cat lbl (minRange rng)
|
||||||
|
keyof (Final _ _ _) = Fin
|
||||||
keyof _
|
keyof _
|
||||||
= Useless
|
= Useless
|
||||||
|
|
||||||
|
|
||||||
{-- Parsing -------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
recognize:
|
-- for tracing purposes
|
||||||
parse : Builds a chart from the initial agenda, given by prediction, and
|
prtSizes chart = "final=" ++ show (length (chartLookup chart Fin)) ++
|
||||||
the inference rules
|
", passive=" ++ show (sum [length (chartLookup chart k) |
|
||||||
keyof : Given an Item returns an appropriate Key for the Chart
|
k@(Pass _ _ _) <- chartKeys chart ]) ++
|
||||||
------------------------------------------------------------------------------}
|
", active=" ++ show (sum [length (chartLookup chart k) |
|
||||||
|
k@(Act _ _ _) <- chartKeys chart ]) ++
|
||||||
recognize mcfg toks = chartMember (parse mcfg toks) item (keyof item)
|
", useless=" ++ show (length (chartLookup chart Useless))
|
||||||
where n = length toks
|
|
||||||
n2 = n `div` 2
|
|
||||||
item = Active ("f",S,[A])
|
|
||||||
[] (Range (0, n)) (Lin "s" []) []
|
|
||||||
[[("p", Range (0, n2)), ("q", Range (n2, n))]]
|
|
||||||
|
|
||||||
|
|
||||||
parse :: (Ord n, Ord c, Ord l, Eq t) => Grammar n c l t -> [t] -> IChart n c l
|
|
||||||
parse mcfg toks = buildChart keyof [complete ntoks, scan, combine] (predict mcfg toks ntoks)
|
|
||||||
where ntoks = length toks
|
|
||||||
|
|
||||||
complete :: (Ord n, Ord c, Ord l) => Int -> IChart n c l
|
|
||||||
-> Item n c l -> [Item n c l]
|
|
||||||
complete ntoks _ (Active rule found rng@(Range (_,j)) (Lin l []) lins recs) =
|
|
||||||
[ Active rule (found ++ [(l, rng)]) (Range (k,k)) lin lins' recs |
|
|
||||||
(lin, lins') <- select lins,
|
|
||||||
k <- [j .. ntoks] ]
|
|
||||||
complete _ _ _ = []
|
|
||||||
|
|
||||||
|
|
||||||
predict :: (Eq n, Eq c, Eq l, Eq t) => Grammar n c l t -> [t] -> Int -> [Item n c l]
|
|
||||||
predict mcfg toks n = [ Active (f, c, rhs) [] (Range (k,k)) lin' lins'' daughters |
|
|
||||||
Rule c rhs lins f <- mcfg,
|
|
||||||
let daughters = replicate (length rhs) [],
|
|
||||||
lins' <- solutions $ rangeRestRec toks lins,
|
|
||||||
(lin', lins'') <- select lins',
|
|
||||||
k <- [0..n] ]
|
|
||||||
|
|
||||||
|
|
||||||
scan :: (Ord n, Ord c, Ord l) => IChart n c l -> Item n c l -> [Item n c l]
|
|
||||||
scan _ (Active rule found rng (Lin l (Tok rng':syms)) lins recs) =
|
|
||||||
[ Active rule found rng'' (Lin l syms) lins recs |
|
|
||||||
rng'' <- solutions $ concRanges rng rng' ]
|
|
||||||
scan _ _ = []
|
|
||||||
|
|
||||||
|
|
||||||
combine :: (Ord n, Ord c, Ord l) => IChart n c l -> Item n c l -> [Item n c l]
|
|
||||||
combine chart (Active rule found rng@(Range (_,j)) (Lin l ((Cat (c,r,d)):syms)) lins recs) =
|
|
||||||
[ Active rule found rng'' (Lin l syms) lins (replaceRec recs d (found' ++ [(l',rng')])) |
|
|
||||||
Active _ found' rng' (Lin l' []) _ _ <- chartLookup chart (Pass c r j),
|
|
||||||
subsumes (recs !! d) (found' ++ [(l',rng')]),
|
|
||||||
rng'' <- solutions $ concRanges rng rng' ]
|
|
||||||
combine chart (Active (_,c,_) found rng'@(Range (i,_)) (Lin l []) _ _) =
|
|
||||||
[ Active rule found' rng'' (Lin l' syms) lins (replaceRec recs d (found ++ [(l,rng')])) |
|
|
||||||
Active rule found' rng (Lin l' ((Cat (c,r,d)):syms)) lins recs
|
|
||||||
<- chartLookup chart (Act c l i),
|
|
||||||
subsumes (recs !! d) (found ++ [(l,rng')]),
|
|
||||||
rng'' <- solutions $ concRanges rng rng' ]
|
|
||||||
combine _ _ = []
|
|
||||||
|
|
||||||
|
|
||||||
|
prtChart chart = concat [ "\n*** KEY: " ++ prt k ++
|
||||||
|
prtBefore "\n " (chartLookup chart k) |
|
||||||
|
k <- chartKeys chart ]
|
||||||
|
|
||||||
|
instance (Print c, Print n, Print l) => Print (Item c n l) where
|
||||||
|
prt (Active abs found rng lin tofind children) =
|
||||||
|
"? " ++ prt abs ++ ";\n\t" ++
|
||||||
|
"{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++
|
||||||
|
prt lin ++ "{" ++ prtSep " " tofind ++ "}" ++
|
||||||
|
( if null children then ";" else ";\n\t" ++
|
||||||
|
"{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" )
|
||||||
|
-- prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}"
|
||||||
|
prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++
|
||||||
|
( if null rrs then ";" else ";\n\t" ++
|
||||||
|
"{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" )
|
||||||
|
|
||||||
|
instance (Print c, Print l) => Print (IKey c l) where
|
||||||
|
prt (Act c l i) = "Active " ++ prt c ++ " " ++ prt l ++ " @ " ++ prt i
|
||||||
|
prt (Pass c l i) = "Passive " ++ prt c ++ " " ++ prt l ++ " @ " ++ prt i
|
||||||
|
prt (Fin) = "Final"
|
||||||
|
prt (Useless) = "Useless"
|
||||||
|
|||||||
144
src/GF/Parsing/MCFG/Incremental2.hs
Normal file
144
src/GF/Parsing/MCFG/Incremental2.hs
Normal file
@@ -0,0 +1,144 @@
|
|||||||
|
|
||||||
|
module GF.Parsing.MCFG.Incremental2 (parse) where
|
||||||
|
|
||||||
|
import Data.List
|
||||||
|
import Data.Array
|
||||||
|
import Control.Monad (guard)
|
||||||
|
|
||||||
|
import GF.Data.Utilities (select)
|
||||||
|
import GF.Data.Assoc
|
||||||
|
import GF.Data.IncrementalDeduction
|
||||||
|
|
||||||
|
import GF.Formalism.GCFG
|
||||||
|
import GF.Formalism.MCFG
|
||||||
|
import GF.Formalism.Utilities
|
||||||
|
|
||||||
|
import GF.Parsing.MCFG.Range
|
||||||
|
import GF.Parsing.MCFG.PInfo
|
||||||
|
|
||||||
|
import GF.System.Tracing
|
||||||
|
import GF.Infra.Print
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- parsing
|
||||||
|
|
||||||
|
-- parseR :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t
|
||||||
|
parse pinfo starts inp =
|
||||||
|
[ Abs (cat, found) (zip rhs rrecs) fun |
|
||||||
|
k <- uncurry enumFromTo (inputBounds inp),
|
||||||
|
Final (Abs cat rhs fun) found rrecs <- chartLookup chart k Fin ]
|
||||||
|
where chart = process pinfo inp
|
||||||
|
|
||||||
|
--process :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> (Int, Int) -> IChart c n l
|
||||||
|
process pinfo inp
|
||||||
|
= tracePrt "MCFG.Incremental - chart size"
|
||||||
|
(prt . map (prtSizes finalChart . fst) . assocs) $
|
||||||
|
finalChart
|
||||||
|
where finalChart = buildChart keyof rules axioms inBounds
|
||||||
|
axioms k = tracePrt ("MCFG.Incremental - axioms for " ++ show k) (prt . length) $
|
||||||
|
predict k ++ scan k ++ complete1 k
|
||||||
|
rules k item = complete2 k item ++ combine k item ++ convert k item
|
||||||
|
inBounds = inputBounds inp
|
||||||
|
|
||||||
|
-- axioms: predict + scan + complete
|
||||||
|
predict k = do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- rulesMatchingInput pinfo inp
|
||||||
|
let daughters = replicate (length rhs) []
|
||||||
|
(lin, lins') <- select lins
|
||||||
|
return $ Active abs [] k lin lins' daughters
|
||||||
|
|
||||||
|
scan k = do (tok, js) <- aAssocs (inputTo inp ! k)
|
||||||
|
j <- js
|
||||||
|
Active abs found i (Lin l (Tok _tok:syms)) lins recs <-
|
||||||
|
chartLookup finalChart j (ActTok tok)
|
||||||
|
return $ Active abs found i (Lin l syms) lins recs
|
||||||
|
|
||||||
|
complete1 k = do j <- [fst inBounds .. k-1]
|
||||||
|
Active abs found i (Lin l _Nil) lins recs <-
|
||||||
|
chartLookup finalChart j Pass
|
||||||
|
let found' = found ++ [(l, makeRange (i,j))]
|
||||||
|
(lin, lins') <- select lins
|
||||||
|
return $ Active abs found' k lin lins' recs
|
||||||
|
|
||||||
|
-- rules: convert + combine + complete
|
||||||
|
convert k (Active rule found j (Lin lbl []) [] recs) =
|
||||||
|
let found' = found ++ [(lbl, makeRange (j,k))]
|
||||||
|
in return $ Final rule found' recs
|
||||||
|
convert _ _ = []
|
||||||
|
|
||||||
|
combine k (Active (Abs cat _ _) found' j (Lin lbl []) _ _) =
|
||||||
|
do guard (j < k) ---- cannot handle epsilon-rules
|
||||||
|
Active abs found i (Lin l (Cat (_cat,_lbl,nr):syms)) lins recs <-
|
||||||
|
chartLookup finalChart j (Act cat lbl)
|
||||||
|
let found'' = found' ++ [(lbl, makeRange (j,k))]
|
||||||
|
recs' <- unifyRec recs nr found''
|
||||||
|
return $ Active abs found i (Lin l syms) lins recs'
|
||||||
|
combine _ _ = []
|
||||||
|
|
||||||
|
complete2 k (Active abs found i (Lin l []) lins recs) =
|
||||||
|
do let found' = found ++ [(l, makeRange (i,k))]
|
||||||
|
(lin, lins') <- select lins
|
||||||
|
return $ Active abs found' k lin lins' recs
|
||||||
|
complete2 _ _ = []
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- type definitions
|
||||||
|
|
||||||
|
type IChart c n l t = IncrementalChart (Item c n l t) (IKey c l t)
|
||||||
|
|
||||||
|
data Item c n l t = Active (Abstract c n)
|
||||||
|
(RangeRec l)
|
||||||
|
Int
|
||||||
|
(Lin c l t)
|
||||||
|
(LinRec c l t)
|
||||||
|
[RangeRec l]
|
||||||
|
| Final (Abstract c n) (RangeRec l) [RangeRec l]
|
||||||
|
-- | Passive c (RangeRec l)
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
data IKey c l t = Act c l
|
||||||
|
| ActTok t
|
||||||
|
-- | Useless
|
||||||
|
| Pass
|
||||||
|
| Fin
|
||||||
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
|
keyof :: Item c n l t -> IKey c l t
|
||||||
|
keyof (Active _ _ _ (Lin _ (Cat (next,lbl,_):_)) _ _) = Act next lbl
|
||||||
|
keyof (Active _ _ _ (Lin _ (Tok tok:_)) _ _) = ActTok tok
|
||||||
|
keyof (Active _ _ _ (Lin _ []) _ _) = Pass
|
||||||
|
keyof (Final _ _ _) = Fin
|
||||||
|
-- keyof _ = Useless
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- for tracing purposes
|
||||||
|
prtSizes chart k = "f=" ++ show (length (chartLookup chart k Fin)) ++
|
||||||
|
" p=" ++ show (length (chartLookup chart k Pass)) ++
|
||||||
|
" a=" ++ show (sum [length (chartLookup chart k key) |
|
||||||
|
key@(Act _ _) <- chartKeys chart k ]) ++
|
||||||
|
" t=" ++ show (sum [length (chartLookup chart k key) |
|
||||||
|
key@(ActTok _) <- chartKeys chart k ])
|
||||||
|
-- " u=" ++ show (length (chartLookup chart k Useless))
|
||||||
|
|
||||||
|
-- prtChart chart = concat [ "\n*** KEY: " ++ prt k ++
|
||||||
|
-- prtBefore "\n " (chartLookup chart k) |
|
||||||
|
-- k <- chartKeys chart ]
|
||||||
|
|
||||||
|
instance (Print c, Print n, Print l, Print t) => Print (Item c n l t) where
|
||||||
|
prt (Active abs found rng lin tofind children) =
|
||||||
|
"? " ++ prt abs ++ ";\n\t" ++
|
||||||
|
"{" ++ prtSep " " found ++ "} " ++ prt rng ++ " . " ++
|
||||||
|
prt lin ++ "{" ++ prtSep " " tofind ++ "}" ++
|
||||||
|
( if null children then ";" else ";\n\t" ++
|
||||||
|
"{" ++ prtSep "} {" (map (prtSep " ") children) ++ "}" )
|
||||||
|
-- prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}"
|
||||||
|
prt (Final abs rr rrs) = ": " ++ prt abs ++ ";\n\t{" ++ prtSep " " rr ++ "}" ++
|
||||||
|
( if null rrs then ";" else ";\n\t" ++
|
||||||
|
"{" ++ prtSep "} {" (map (prtSep " ") rrs) ++ "}" )
|
||||||
|
|
||||||
|
instance (Print c, Print l, Print t) => Print (IKey c l t) where
|
||||||
|
prt (Act c l) = "Active " ++ prt c ++ " " ++ prt l
|
||||||
|
prt (ActTok t) = "ActiveTok " ++ prt t
|
||||||
|
-- prt (Pass c l i) = "Passive " ++ prt c ++ " " ++ prt l ++ " @ " ++ prt i
|
||||||
|
prt (Fin) = "Final"
|
||||||
|
-- prt (Useless) = "Useless"
|
||||||
@@ -1,6 +1,7 @@
|
|||||||
|
|
||||||
module GF.Parsing.MCFG.Naive (parse) where
|
module GF.Parsing.MCFG.Naive (parse, parseR) where
|
||||||
|
|
||||||
|
import Control.Monad (guard)
|
||||||
|
|
||||||
-- GF modules
|
-- GF modules
|
||||||
import GF.Data.GeneralDeduction
|
import GF.Data.GeneralDeduction
|
||||||
@@ -13,21 +14,72 @@ import GF.Data.SortedList
|
|||||||
import GF.Data.Assoc
|
import GF.Data.Assoc
|
||||||
import GF.System.Tracing
|
import GF.System.Tracing
|
||||||
|
|
||||||
|
import GF.Infra.Print
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- * parsing
|
-- * parsing
|
||||||
|
|
||||||
-- | Builds a chart from the initial agenda, given by prediction, and
|
-- | Builds a chart from the initial agenda, given by prediction, and the inference rules
|
||||||
-- the inference rules
|
|
||||||
parse :: (Ord t, Ord n, Ord c, Ord l) => MCFParser c n l t
|
parse :: (Ord t, Ord n, Ord c, Ord l) => MCFParser c n l t
|
||||||
parse mcfg starts toks
|
parse pinfo starts toks
|
||||||
= [ Abs (cat, makeRangeRec lins) (zip rhs rrecs) fun |
|
= [ Abs (cat, makeRangeRec lins) (zip rhs rrecs) fun |
|
||||||
Active (Abs cat _Nil fun, rhs) lins rrecs <- chartLookup chart Final ]
|
Active (Abs cat _Nil fun, rhs) lins rrecs <- chartLookup chart Final ]
|
||||||
where chart = process mcfg toks
|
where chart = process pinfo toks
|
||||||
|
|
||||||
process :: (Ord t, Ord n, Ord c, Ord l) => MCFGrammar c n l t -> Input t -> NChart c n l
|
-- | Builds a chart from the initial agenda, given by prediction, and the inference rules
|
||||||
process mcfg toks
|
-- parseR :: (Ord t, Ord n, Ord c, Ord l) => MCFParser c n l t
|
||||||
|
parseR pinfo starts
|
||||||
|
= [ Abs (cat, makeRangeRec lins) (zip rhs rrecs) fun |
|
||||||
|
Active (Abs cat _Nil fun, rhs) lins rrecs <- chartLookup chart Final ]
|
||||||
|
where chart = processR pinfo
|
||||||
|
|
||||||
|
process :: (Ord t, Ord n, Ord c, Ord l) => MCFPInfo c n l t -> Input t -> NChart c n l
|
||||||
|
process pinfo toks
|
||||||
= tracePrt "MCFG.Naive - chart size" prtSizes $
|
= tracePrt "MCFG.Naive - chart size" prtSizes $
|
||||||
buildChart keyof [convert, combine] (predict toks mcfg)
|
buildChart keyof [convert, combine] (predict pinfo toks)
|
||||||
|
|
||||||
|
processR :: (Ord n, Ord c, Ord l) => MCFPInfo c n l Range -> NChart c n l
|
||||||
|
processR pinfo
|
||||||
|
= tracePrt "MCFG.Naive Range - chart size" prtSizes $
|
||||||
|
buildChart keyof [convert, combine] (predictR pinfo)
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- * inference rules
|
||||||
|
|
||||||
|
-- Creates an Active Item of every Rule in the Grammar to give the initial Agenda
|
||||||
|
predict :: (Ord l, Ord t) => MCFPInfo c n l t -> Input t -> [Item c n l]
|
||||||
|
predict pinfo toks = tracePrt "MCFG.Naive - predicted rules" (prt . length) $
|
||||||
|
do Rule abs (Cnc _ _ lins) <- rulesMatchingInput pinfo toks
|
||||||
|
lins' <- rangeRestRec toks lins
|
||||||
|
return $ Active (abs, []) lins' []
|
||||||
|
|
||||||
|
-- Creates an Active Item of every Rule in the Grammar to give the initial Agenda
|
||||||
|
predictR :: (Ord l) => MCFPInfo c n l Range -> [Item c n l]
|
||||||
|
predictR pinfo = tracePrt "MCFG.Naive Range - predicted rules" (prt . length) $
|
||||||
|
do Rule abs (Cnc _ _ lins) <- allRules pinfo
|
||||||
|
return $ Active (abs, []) lins []
|
||||||
|
|
||||||
|
-- | Creates an Active Item every time it is possible to combine
|
||||||
|
-- an Active Item from the agenda with a Passive Item from the Chart
|
||||||
|
combine :: (Ord n, Ord c, Ord l) => NChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
combine chart item@(Active (Abs _ (c:_) _, _) _ _) =
|
||||||
|
do Passive _c rrec <- chartLookup chart (Pass c)
|
||||||
|
combine2 chart rrec item
|
||||||
|
combine chart (Passive c rrec) =
|
||||||
|
do item <- chartLookup chart (Act c)
|
||||||
|
combine2 chart rrec item
|
||||||
|
combine _ _ = []
|
||||||
|
|
||||||
|
combine2 chart rrec (Active (Abs nt (c:find) f, found) lins rrecs) =
|
||||||
|
do lins' <- substArgRec (length found) rrec lins
|
||||||
|
return $ Active (Abs nt find f, found ++ [c]) lins' (rrecs ++ [rrec])
|
||||||
|
|
||||||
|
-- | Active Items with nothing to find are converted to Passive Items
|
||||||
|
convert :: (Ord n, Ord c, Ord l) => NChart c n l -> Item c n l -> [Item c n l]
|
||||||
|
convert _ (Active (Abs cat [] fun, _) lins _) = [Passive cat (makeRangeRec lins)]
|
||||||
|
convert _ _ = []
|
||||||
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- * type definitions
|
-- * type definitions
|
||||||
@@ -57,32 +109,20 @@ prtSizes chart = "final=" ++ show (length (chartLookup chart Final)) ++
|
|||||||
", active=" ++ show (sum [length (chartLookup chart k) |
|
", active=" ++ show (sum [length (chartLookup chart k) |
|
||||||
k@(Act _) <- chartKeys chart ])
|
k@(Act _) <- chartKeys chart ])
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
prtChart chart = concat [ "\n*** KEY: " ++ prt k ++
|
||||||
-- * inference rules
|
prtBefore "\n " (chartLookup chart k) |
|
||||||
|
k <- chartKeys chart ]
|
||||||
|
|
||||||
-- Creates an Active Item of every Rule in the Grammar to give the initial Agenda
|
instance (Print c, Print n, Print l) => Print (Item c n l) where
|
||||||
predict :: Ord t => Input t -> MCFGrammar c n l t -> [Item c n l]
|
prt (Active (abs, cs) lrec rrecs) = "? " ++ prt abs ++ " . " ++ prtSep " " cs ++ ";\n\t" ++
|
||||||
predict toks mcfg = [ Active (abs, []) lins' [] |
|
"{" ++ prtSep " " lrec ++ "}" ++
|
||||||
Rule abs (Cnc _ _ lins) <- mcfg,
|
( if null rrecs then ";" else ";\n\t" ++
|
||||||
lins' <- rangeRestRec toks lins ]
|
"{" ++ prtSep "} {" (map (prtSep " ") rrecs) ++ "}" )
|
||||||
|
prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}"
|
||||||
|
|
||||||
-- | Creates an Active Item every time it is possible to combine
|
instance Print c => Print (NKey c) where
|
||||||
-- an Active Item from the agenda with a Passive Item from the Chart
|
prt (Act c) = "Active " ++ prt c
|
||||||
combine :: (Ord n, Ord c, Ord l) => NChart c n l -> Item c n l -> [Item c n l]
|
prt (Pass c) = "Passive " ++ prt c
|
||||||
combine chart (Active (Abs nt (c:find) f, found) lins rrecs) =
|
prt (Final) = "Final"
|
||||||
do Passive _ rrec <- chartLookup chart (Pass c)
|
|
||||||
lins' <- concLinRec $ substArgRec (length found) rrec lins
|
|
||||||
return $ Active (Abs nt find f, found ++ [c]) lins' (rrecs ++ [rrec])
|
|
||||||
combine chart (Passive c rrec) =
|
|
||||||
do Active (Abs nt (c:find) f, found) lins rrecs <- chartLookup chart (Act c)
|
|
||||||
lins' <- concLinRec $ substArgRec (length found) rrec lins
|
|
||||||
return $ Active (Abs nt find f, found ++ [c]) lins' (rrecs ++ [rrec])
|
|
||||||
combine _ _ = []
|
|
||||||
|
|
||||||
-- | Active Items with nothing to find are converted to Passive Items
|
|
||||||
convert :: (Ord n, Ord c, Ord l) => NChart c n l -> Item c n l -> [Item c n l]
|
|
||||||
convert _ (Active (Abs cat [] _, _) lins _) = [Passive cat rrec]
|
|
||||||
where rrec = makeRangeRec lins
|
|
||||||
convert _ _ = []
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@@ -4,9 +4,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:23:14 $
|
-- > CVS $Date: 2005/05/09 09:28:46 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.3 $
|
-- > CVS $Revision: 1.4 $
|
||||||
--
|
--
|
||||||
-- MCFG parsing, parser information
|
-- MCFG parsing, parser information
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -34,11 +34,130 @@ type MCFParser c n l t = MCFPInfo c n l t
|
|||||||
|
|
||||||
type MCFChart c n l = [Abstract (c, RangeRec l) n]
|
type MCFChart c n l = [Abstract (c, RangeRec l) n]
|
||||||
|
|
||||||
type MCFPInfo c n l t = MCFGrammar c n l t
|
|
||||||
|
|
||||||
buildMCFPInfo :: (Ord n, Ord c, Ord l, Ord t) => MCFGrammar c n l t -> MCFPInfo c n l t
|
|
||||||
buildMCFPInfo = id
|
|
||||||
|
|
||||||
makeFinalEdge :: c -> l -> (Int, Int) -> (c, RangeRec l)
|
makeFinalEdge :: c -> l -> (Int, Int) -> (c, RangeRec l)
|
||||||
makeFinalEdge cat lbl bnds = (cat, [(lbl, makeRange bnds)])
|
makeFinalEdge cat lbl bnds = (cat, [(lbl, makeRange bnds)])
|
||||||
|
|
||||||
|
|
||||||
|
------------------------------------------------------------
|
||||||
|
-- parser information
|
||||||
|
|
||||||
|
data MCFPInfo c n l t
|
||||||
|
= MCFPInfo { grammarTokens :: SList t
|
||||||
|
, nameRules :: Assoc n (SList (MCFRule c n l t))
|
||||||
|
, topdownRules :: Assoc c (SList (MCFRule c n l t))
|
||||||
|
-- ^ used in 'GF.Parsing.MCFG.Active' (Earley):
|
||||||
|
, emptyRules :: [MCFRule c n l t]
|
||||||
|
, leftcornerCats :: Assoc c (SList (MCFRule c n l t))
|
||||||
|
, leftcornerTokens :: Assoc t (SList (MCFRule c n l t))
|
||||||
|
-- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury):
|
||||||
|
, grammarCats :: SList c
|
||||||
|
-- ^ used when calculating starting categories
|
||||||
|
, rulesByToken :: Assoc t (SList (MCFRule c n l t, SList t))
|
||||||
|
, rulesWithoutTokens :: SList (MCFRule c n l t)
|
||||||
|
-- ^ used by 'rulesMatchingInput'
|
||||||
|
, allRules :: MCFGrammar c n l t
|
||||||
|
-- ^ used by any unoptimized algorithm
|
||||||
|
|
||||||
|
--bottomupRules :: Assoc (Symbol c t) (SList (CFRule c n t)),
|
||||||
|
--emptyLeftcornerRules :: Assoc c (SList (CFRule c n t)),
|
||||||
|
--emptyCategories :: Set c,
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
rangeRestrictPInfo :: (Ord c, Ord n, Ord l, Ord t) =>
|
||||||
|
MCFPInfo c n l t -> Input t -> MCFPInfo c n l Range
|
||||||
|
rangeRestrictPInfo (pinfo{-::MCFPInfo c n l t-}) inp =
|
||||||
|
tracePrt "MCFG.PInfo - Restricting the parser information" (prt . grammarTokens)
|
||||||
|
MCFPInfo { grammarTokens = nubsort (map edgeRange (inputEdges inp))
|
||||||
|
, nameRules = rrAssoc (nameRules pinfo)
|
||||||
|
, topdownRules = rrAssoc (topdownRules pinfo)
|
||||||
|
, emptyRules = rrRules (emptyRules pinfo)
|
||||||
|
, leftcornerCats = rrAssoc (leftcornerCats pinfo)
|
||||||
|
, leftcornerTokens = lctokens
|
||||||
|
, grammarCats = grammarCats pinfo
|
||||||
|
, rulesByToken = emptyAssoc -- error "MCFG.PInfo.rulesByToken - no range restriction"
|
||||||
|
, rulesWithoutTokens = [] -- error "MCFG.PInfo.rulesByToken - no range restriction"
|
||||||
|
, allRules = allrules -- rrRules (allRules pinfo)
|
||||||
|
}
|
||||||
|
|
||||||
|
where lctokens = accumAssoc id
|
||||||
|
[ (rng, rule) | (tok, rules) <- aAssocs (leftcornerTokens pinfo),
|
||||||
|
inputToken inp ?= tok,
|
||||||
|
rule@(Rule _ (Cnc _ _ (Lin _ (Tok rng:_) : _)))
|
||||||
|
<- concatMap (rangeRestrictRule inp) rules ]
|
||||||
|
|
||||||
|
allrules = rrRules $ rulesMatchingInput pinfo inp
|
||||||
|
|
||||||
|
rrAssoc assoc = filterNull $ fmap rrRules assoc
|
||||||
|
filterNull assoc = assocFilter (not . null) assoc
|
||||||
|
rrRules rules = concatMap (rangeRestrictRule inp) rules
|
||||||
|
|
||||||
|
|
||||||
|
buildMCFPInfo :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> MCFPInfo c n l t
|
||||||
|
buildMCFPInfo grammar =
|
||||||
|
traceCalcFirst grammar $
|
||||||
|
tracePrt "MCFG.PInfo - parser info" (prt) $
|
||||||
|
MCFPInfo { grammarTokens = grammartokens
|
||||||
|
, nameRules = namerules
|
||||||
|
, topdownRules = topdownrules
|
||||||
|
, emptyRules = emptyrules
|
||||||
|
, leftcornerCats = leftcorncats
|
||||||
|
, leftcornerTokens = leftcorntoks
|
||||||
|
, grammarCats = grammarcats
|
||||||
|
, rulesByToken = rulesbytoken
|
||||||
|
, rulesWithoutTokens = ruleswithouttokens
|
||||||
|
, allRules = allrules
|
||||||
|
}
|
||||||
|
|
||||||
|
where allrules = concatMap expandVariants grammar
|
||||||
|
grammartokens = union (map fst ruletokens)
|
||||||
|
namerules = accumAssoc id
|
||||||
|
[ (name, rule) | rule@(Rule (Abs _ _ name) _) <- allrules ]
|
||||||
|
topdownrules = accumAssoc id
|
||||||
|
[ (cat, rule) | rule@(Rule (Abs cat _ _) _) <- allrules ]
|
||||||
|
emptyrules = [ rule | rule@(Rule (Abs _ [] _) _) <- allrules ]
|
||||||
|
leftcorncats = accumAssoc id
|
||||||
|
[ (cat, rule) |
|
||||||
|
rule@(Rule _ (Cnc _ _ (Lin _ (Cat(cat,_,_):_) : _))) <- allrules ]
|
||||||
|
leftcorntoks = accumAssoc id
|
||||||
|
[ (tok, rule) |
|
||||||
|
rule@(Rule _ (Cnc _ _ (Lin _ (Tok tok:_) : _))) <- allrules ]
|
||||||
|
grammarcats = aElems topdownrules
|
||||||
|
ruletokens = [ (toksoflins lins, rule) |
|
||||||
|
rule@(Rule _ (Cnc _ _ lins)) <- allrules ]
|
||||||
|
toksoflins lins = nubsort [ tok | Lin _ syms <- lins, Tok tok <- syms ]
|
||||||
|
rulesbytoken = accumAssoc id
|
||||||
|
[ (tok, (rule, toks)) | (tok:toks, rule) <- ruletokens ]
|
||||||
|
ruleswithouttokens = nubsort [ rule | ([], rule) <- ruletokens ]
|
||||||
|
|
||||||
|
|
||||||
|
-- | return only the rules for which all tokens are in the input string
|
||||||
|
rulesMatchingInput :: Ord t => MCFPInfo c n l t -> Input t -> [MCFRule c n l t]
|
||||||
|
rulesMatchingInput pinfo inp =
|
||||||
|
[ rule | tok <- toks,
|
||||||
|
(rule, ruletoks) <- rulesByToken pinfo ? tok,
|
||||||
|
ruletoks `subset` toks ]
|
||||||
|
++ rulesWithoutTokens pinfo
|
||||||
|
where toks = aElems (inputToken inp)
|
||||||
|
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- pretty-printing of statistics
|
||||||
|
|
||||||
|
instance (Ord c, Ord n, Ord l, Ord t) => Print (MCFPInfo c n l t) where
|
||||||
|
prt pI = "[ tokens=" ++ sl grammarTokens ++
|
||||||
|
"; categories=" ++ sl grammarCats ++
|
||||||
|
"; nameRules=" ++ sla nameRules ++
|
||||||
|
"; tdRules=" ++ sla topdownRules ++
|
||||||
|
"; emptyRules=" ++ sl emptyRules ++
|
||||||
|
"; lcCats=" ++ sla leftcornerCats ++
|
||||||
|
"; lcTokens=" ++ sla leftcornerTokens ++
|
||||||
|
"; byToken=" ++ sla rulesByToken ++
|
||||||
|
"; noTokens=" ++ sl rulesWithoutTokens ++
|
||||||
|
"; allRules=" ++ sl allRules ++
|
||||||
|
" ]"
|
||||||
|
|
||||||
|
where sl f = show $ length $ f pI
|
||||||
|
sla f = let (as, bs) = unzip $ aAssocs $ f pI
|
||||||
|
in show (length as) ++ "/" ++ show (length (concat bs))
|
||||||
|
|
||||||
|
|||||||
@@ -1,5 +1,10 @@
|
|||||||
|
|
||||||
module GF.Parsing.MCFG.Range where
|
module GF.Parsing.MCFG.Range
|
||||||
|
( Range(..), makeRange, concatRange, rangeEdge, edgeRange, minRange, maxRange,
|
||||||
|
LinRec, RangeRec,
|
||||||
|
makeRangeRec, rangeRestRec, rangeRestrictRule,
|
||||||
|
projection, unifyRec, substArgRec
|
||||||
|
) where
|
||||||
|
|
||||||
|
|
||||||
-- Haskell
|
-- Haskell
|
||||||
@@ -12,6 +17,7 @@ import GF.Formalism.MCFG
|
|||||||
import GF.Formalism.Utilities
|
import GF.Formalism.Utilities
|
||||||
import GF.Infra.Print
|
import GF.Infra.Print
|
||||||
import GF.Data.Assoc ((?))
|
import GF.Data.Assoc ((?))
|
||||||
|
import GF.Data.Utilities (updateNthM)
|
||||||
|
|
||||||
------------------------------------------------------------
|
------------------------------------------------------------
|
||||||
-- ranges as single pairs
|
-- ranges as single pairs
|
||||||
@@ -23,6 +29,7 @@ data Range = Range (Int, Int)
|
|||||||
makeRange :: (Int, Int) -> Range
|
makeRange :: (Int, Int) -> Range
|
||||||
concatRange :: Range -> Range -> [Range]
|
concatRange :: Range -> Range -> [Range]
|
||||||
rangeEdge :: a -> Range -> Edge a
|
rangeEdge :: a -> Range -> Edge a
|
||||||
|
edgeRange :: Edge a -> Range
|
||||||
minRange :: Range -> Int
|
minRange :: Range -> Int
|
||||||
maxRange :: Range -> Int
|
maxRange :: Range -> Int
|
||||||
|
|
||||||
@@ -31,6 +38,7 @@ concatRange EmptyRange rng = return rng
|
|||||||
concatRange rng EmptyRange = return rng
|
concatRange rng EmptyRange = return rng
|
||||||
concatRange (Range(i,j)) (Range(j',k)) = [ Range(i,k) | j==j']
|
concatRange (Range(i,j)) (Range(j',k)) = [ Range(i,k) | j==j']
|
||||||
rangeEdge a (Range(i,j)) = Edge i j a
|
rangeEdge a (Range(i,j)) = Edge i j a
|
||||||
|
edgeRange (Edge i j _) = Range (i,j)
|
||||||
minRange (Range rho) = fst rho
|
minRange (Range rho) = fst rho
|
||||||
maxRange (Range rho) = snd rho
|
maxRange (Range rho) = snd rho
|
||||||
|
|
||||||
@@ -91,6 +99,8 @@ concLinRec = mapM concLin
|
|||||||
makeRangeRec :: LinRec c l Range -> RangeRec l
|
makeRangeRec :: LinRec c l Range -> RangeRec l
|
||||||
makeRangeRec lins = map convLin lins
|
makeRangeRec lins = map convLin lins
|
||||||
where convLin (Lin lbl [Tok rng]) = (lbl, rng)
|
where convLin (Lin lbl [Tok rng]) = (lbl, rng)
|
||||||
|
convLin (Lin lbl []) = (lbl, EmptyRange)
|
||||||
|
convLin _ = error "makeRangeRec"
|
||||||
|
|
||||||
|
|
||||||
--- Record projection --------------------------------------------------------
|
--- Record projection --------------------------------------------------------
|
||||||
@@ -114,51 +124,59 @@ rangeRestSym _ (Cat c) = return (Cat c)
|
|||||||
|
|
||||||
rangeRestLin :: Ord t => Input t -> Lin c l t -> [Lin c l Range]
|
rangeRestLin :: Ord t => Input t -> Lin c l t -> [Lin c l Range]
|
||||||
rangeRestLin toks (Lin lbl syms) = do syms' <- mapM (rangeRestSym toks) syms
|
rangeRestLin toks (Lin lbl syms) = do syms' <- mapM (rangeRestSym toks) syms
|
||||||
return (Lin lbl syms')
|
concLin (Lin lbl syms')
|
||||||
|
-- return (Lin lbl syms')
|
||||||
|
|
||||||
|
|
||||||
rangeRestRec :: Ord t => Input t -> LinRec c l t -> [LinRec c l Range]
|
rangeRestRec :: Ord t => Input t -> LinRec c l t -> [LinRec c l Range]
|
||||||
rangeRestRec toks = mapM (rangeRestLin toks)
|
rangeRestRec toks = mapM (rangeRestLin toks)
|
||||||
|
|
||||||
|
|
||||||
-- Record replacment ---------------------------------------------------------
|
rangeRestrictRule :: Ord t => Input t -> MCFRule c n l t -> [MCFRule c n l Range]
|
||||||
-- ineffektiv!!
|
rangeRestrictRule toks (Rule abs (Cnc l ls lins)) = liftM (Rule abs . Cnc l ls) $
|
||||||
|
rangeRestRec toks lins
|
||||||
replaceRec :: [RangeRec l] -> Int -> RangeRec l -> [RangeRec l]
|
|
||||||
replaceRec recs i rec = (fst tup) ++ [rec] ++ (tail $ snd tup)
|
|
||||||
where tup = splitAt i recs
|
|
||||||
|
|
||||||
|
|
||||||
--- Argument substitution ----------------------------------------------------
|
--- Argument substitution ----------------------------------------------------
|
||||||
|
|
||||||
substArgSymbol :: Ord l => Int -> RangeRec l -> Symbol (c, l, Int) Range
|
substArgSymbol :: Ord l => Int -> RangeRec l -> Symbol (c, l, Int) Range
|
||||||
-> Symbol (c, l, Int) Range
|
-> Symbol (c, l, Int) Range
|
||||||
substArgSymbol i rec (Tok rng) = (Tok rng)
|
substArgSymbol i rec tok@(Tok rng) = tok
|
||||||
substArgSymbol i rec (Cat (c, l, j))
|
substArgSymbol i rec cat@(Cat (c, l, j))
|
||||||
| i==j = maybe (Cat (c, l, j)) Tok $ lookup l rec
|
| i==j = maybe err Tok $ lookup l rec
|
||||||
| otherwise = (Cat (c, l, j))
|
| otherwise = cat
|
||||||
|
where err = error "substArg: Label not in range-record"
|
||||||
|
|
||||||
substArgLin :: Ord l => Int -> RangeRec l -> Lin c l Range
|
substArgLin :: Ord l => Int -> RangeRec l -> Lin c l Range
|
||||||
-> Lin c l Range
|
-> [Lin c l Range]
|
||||||
substArgLin i rec (Lin lbl syms) =
|
substArgLin i rec (Lin lbl syms) =
|
||||||
(Lin lbl (map (substArgSymbol i rec) syms))
|
concLin (Lin lbl (map (substArgSymbol i rec) syms))
|
||||||
|
|
||||||
|
|
||||||
substArgRec :: Ord l => Int -> RangeRec l -> LinRec c l Range
|
substArgRec :: Ord l => Int -> RangeRec l -> LinRec c l Range
|
||||||
-> LinRec c l Range
|
-> [LinRec c l Range]
|
||||||
substArgRec i rec lins = map (substArgLin i rec) lins
|
substArgRec i rec lins = mapM (substArgLin i rec) lins
|
||||||
|
|
||||||
|
|
||||||
--- Subsumation -------------------------------------------------------------
|
-- Record unification & replacment ---------------------------------------------------------
|
||||||
|
|
||||||
|
unifyRec :: Ord l => [RangeRec l] -> Int -> RangeRec l -> [[RangeRec l]]
|
||||||
|
unifyRec recs i rec = updateNthM update i recs
|
||||||
|
where update rec' = guard (subsumes rec' rec) >> return rec
|
||||||
|
|
||||||
|
-- unifyRec recs i rec = do guard $ subsumes (recs !! i) rec
|
||||||
|
-- return $ replaceRec recs i rec
|
||||||
|
|
||||||
|
replaceRec :: [RangeRec l] -> Int -> RangeRec l -> [RangeRec l]
|
||||||
|
replaceRec recs i rec = before ++ (rec : after)
|
||||||
|
where (before, _ : after) = splitAt i recs
|
||||||
|
|
||||||
-- "rec' subsumes rec?"
|
|
||||||
subsumes :: Ord l => RangeRec l -> RangeRec l -> Bool
|
subsumes :: Ord l => RangeRec l -> RangeRec l -> Bool
|
||||||
subsumes rec rec' = and [elem r rec' | r <- rec]
|
subsumes rec rec' = and [r `elem` rec' | r <- rec]
|
||||||
|
-- subsumes rec rec' = all (`elem` rec') rec
|
||||||
|
|
||||||
|
|
||||||
|
{-
|
||||||
--- Record unification -------------------------------------------------------
|
--- Record unification -------------------------------------------------------
|
||||||
|
|
||||||
unifyRangeRecs :: Ord l => [RangeRec l] -> [RangeRec l] -> [[RangeRec l]]
|
unifyRangeRecs :: Ord l => [RangeRec l] -> [RangeRec l] -> [[RangeRec l]]
|
||||||
unifyRangeRecs recs recs' = zipWithM unify recs recs'
|
unifyRangeRecs recs recs' = zipWithM unify recs recs'
|
||||||
where unify :: Ord l => RangeRec l -> RangeRec l -> [RangeRec l]
|
where unify :: Ord l => RangeRec l -> RangeRec l -> [RangeRec l]
|
||||||
@@ -173,3 +191,4 @@ unifyRangeRecs recs recs' = zipWithM unify recs recs'
|
|||||||
EQ -> do guard (r1 == r2)
|
EQ -> do guard (r1 == r2)
|
||||||
rec3 <- unify rec1 rec2
|
rec3 <- unify rec1 rec2
|
||||||
return (p1:rec3)
|
return (p1:rec3)
|
||||||
|
-}
|
||||||
|
|||||||
@@ -5,9 +5,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:23:22 $
|
-- > CVS $Date: 2005/05/09 09:28:46 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.30 $
|
-- > CVS $Revision: 1.31 $
|
||||||
--
|
--
|
||||||
-- The datatype of shell commands and the list of their options.
|
-- The datatype of shell commands and the list of their options.
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -129,7 +129,9 @@ testValidFlag st co f x = case f of
|
|||||||
"unlexer" -> testInc customUntokenizer
|
"unlexer" -> testInc customUntokenizer
|
||||||
"depth" -> testN
|
"depth" -> testN
|
||||||
"rawtrees"-> testN
|
"rawtrees"-> testN
|
||||||
"parser" -> testInc customParser
|
"parser" -> testInc customParser
|
||||||
|
-- hack for the -newer parsers: (to be changed)
|
||||||
|
`mplus` if not(null x) && head x `elem` "mc" then return () else Bad ""
|
||||||
"alts" -> testN
|
"alts" -> testN
|
||||||
"transform" -> testInc customTermCommand
|
"transform" -> testInc customTermCommand
|
||||||
"filter" -> testInc customStringCommand
|
"filter" -> testInc customStringCommand
|
||||||
@@ -158,7 +160,7 @@ optionsOfCommand co = case co of
|
|||||||
"cat lang lexer parser number depth rawtrees unlexer optimize path conversion printer"
|
"cat lang lexer parser number depth rawtrees unlexer optimize path conversion printer"
|
||||||
|
|
||||||
CImport _ -> both "old v s src retain nocf nocheckcirc cflexer noemit o"
|
CImport _ -> both "old v s src retain nocf nocheckcirc cflexer noemit o"
|
||||||
"abs cnc res path optimize conversion"
|
"abs cnc res path optimize conversion cat"
|
||||||
CRemoveLanguage _ -> none
|
CRemoveLanguage _ -> none
|
||||||
CEmptyState -> none
|
CEmptyState -> none
|
||||||
CStripState -> none
|
CStripState -> none
|
||||||
|
|||||||
@@ -5,9 +5,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:23:44 $
|
-- > CVS $Date: 2005/05/09 09:28:46 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.58 $
|
-- > CVS $Revision: 1.59 $
|
||||||
--
|
--
|
||||||
-- A database for customizable GF shell commands.
|
-- A database for customizable GF shell commands.
|
||||||
--
|
--
|
||||||
@@ -252,8 +252,13 @@ customGrammarPrinter =
|
|||||||
-- grammar conversions:
|
-- grammar conversions:
|
||||||
,(strCI "mcfg", Prt.prt . stateMCFG)
|
,(strCI "mcfg", Prt.prt . stateMCFG)
|
||||||
,(strCI "cfg", Prt.prt . stateCFG)
|
,(strCI "cfg", Prt.prt . stateCFG)
|
||||||
|
,(strCI "pinfo", Prt.prt . statePInfo)
|
||||||
|
,(strCI "abstract", Prt.prtAfter "\n" . Cnv.gfc2abstract . stateGrammarLang)
|
||||||
-- obsolete, or only for testing:
|
-- obsolete, or only for testing:
|
||||||
|
,(strCI "abs-pl", Cnv.abstract2prolog . Cnv.gfc2abstract . stateGrammarLang)
|
||||||
|
,(strCI "cfg-pl", Cnv.cfg2prolog . stateCFG)
|
||||||
,(strCI "simple", Prt.prt . Cnv.gfc2simple . stateGrammarLang)
|
,(strCI "simple", Prt.prt . Cnv.gfc2simple . stateGrammarLang)
|
||||||
|
,(strCI "mcfg-erasing", Prt.prt . Cnv.simple2mcfg_nondet . Cnv.gfc2simple . stateGrammarLang)
|
||||||
,(strCI "finite", Prt.prt . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
|
,(strCI "finite", Prt.prt . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
|
||||||
,(strCI "single", Prt.prt . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
|
,(strCI "single", Prt.prt . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
|
||||||
,(strCI "sg-sg", Prt.prt . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
|
,(strCI "sg-sg", Prt.prt . Cnv.removeSingletons . Cnv.removeSingletons . Cnv.simple2finite . Cnv.gfc2simple . stateGrammarLang)
|
||||||
|
|||||||
@@ -5,9 +5,9 @@
|
|||||||
-- Stability : (stable)
|
-- Stability : (stable)
|
||||||
-- Portability : (portable)
|
-- Portability : (portable)
|
||||||
--
|
--
|
||||||
-- > CVS $Date: 2005/04/21 16:23:50 $
|
-- > CVS $Date: 2005/05/09 09:28:46 $
|
||||||
-- > CVS $Author: bringert $
|
-- > CVS $Author: peb $
|
||||||
-- > CVS $Revision: 1.20 $
|
-- > CVS $Revision: 1.21 $
|
||||||
--
|
--
|
||||||
-- (Description of the module)
|
-- (Description of the module)
|
||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
@@ -107,7 +107,7 @@ trees2trms opts sg cn as ts0 info = do
|
|||||||
show (length ts0) +++
|
show (length ts0) +++
|
||||||
"considered; use -rawtrees=<Int> to see more"
|
"considered; use -rawtrees=<Int> to see more"
|
||||||
)
|
)
|
||||||
(ts1,ss) <- checkErr $ mapErrN 10 postParse ts01
|
(ts1,ss) <- checkErr $ mapErrN 1 postParse ts01
|
||||||
if null ts1 then raise ss else return ()
|
if null ts1 then raise ss else return ()
|
||||||
ts2 <- mapM (checkErr . annotate gr . refreshMetas [] . trExp) ts1 ----
|
ts2 <- mapM (checkErr . annotate gr . refreshMetas [] . trExp) ts1 ----
|
||||||
if forgive then return ts2 else do
|
if forgive then return ts2 else do
|
||||||
|
|||||||
@@ -99,6 +99,7 @@ ghci-trace: GHCFLAGS += -DTRACING
|
|||||||
ghci-trace: ghci
|
ghci-trace: ghci
|
||||||
|
|
||||||
touch-files:
|
touch-files:
|
||||||
|
rm -f GF/System/Tracing.{hi,o}
|
||||||
touch GF/System/Tracing.hs
|
touch GF/System/Tracing.hs
|
||||||
|
|
||||||
# profiling
|
# profiling
|
||||||
|
|||||||
Reference in New Issue
Block a user