diff options
| author | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:43:48 +0000 |
|---|---|---|
| committer | aarne <aarne@cs.chalmers.se> | 2008-06-25 16:43:48 +0000 |
| commit | b96b36f43de3e2f8b58d5f539daa6f6d47f25870 (patch) | |
| tree | 0992334be13cec6538a1dea22fbbf26ad6bdf224 /src/GF/Parsing | |
| parent | fe367412e0aeb4ad5c02de68e6eca382e0f96984 (diff) | |
removed src for 2.9
Diffstat (limited to 'src/GF/Parsing')
| -rw-r--r-- | src/GF/Parsing/CF.hs | 66 | ||||
| -rw-r--r-- | src/GF/Parsing/CFG.hs | 51 | ||||
| -rw-r--r-- | src/GF/Parsing/CFG/General.hs | 103 | ||||
| -rw-r--r-- | src/GF/Parsing/CFG/Incremental.hs | 150 | ||||
| -rw-r--r-- | src/GF/Parsing/CFG/PInfo.hs | 98 | ||||
| -rw-r--r-- | src/GF/Parsing/FCFG.hs | 100 | ||||
| -rw-r--r-- | src/GF/Parsing/FCFG/Active.hs | 179 | ||||
| -rw-r--r-- | src/GF/Parsing/FCFG/Incremental.hs | 107 | ||||
| -rw-r--r-- | src/GF/Parsing/FCFG/PInfo.hs | 121 | ||||
| -rw-r--r-- | src/GF/Parsing/FCFG/Range.hs | 50 | ||||
| -rw-r--r-- | src/GF/Parsing/GFC.hs | 208 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG.hs | 68 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG/Active.hs | 318 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG/Active2.hs | 237 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG/FastActive.hs | 176 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG/Incremental.hs | 178 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG/Incremental2.hs | 157 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG/Naive.hs | 142 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG/PInfo.hs | 162 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG/Range.hs | 206 | ||||
| -rw-r--r-- | src/GF/Parsing/MCFG/ViaCFG.hs | 186 |
21 files changed, 0 insertions, 3063 deletions
diff --git a/src/GF/Parsing/CF.hs b/src/GF/Parsing/CF.hs deleted file mode 100644 index 1a65f6caf..000000000 --- a/src/GF/Parsing/CF.hs +++ /dev/null @@ -1,66 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Chart parsing of grammars in CF format ------------------------------------------------------------------------------ - -module GF.Parsing.CF (parse) where - -import GF.Data.Operations (errVal) - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Data.SortedList (nubsort) -import GF.Data.Assoc -import qualified GF.CF.CF as CF -import qualified GF.CF.CFIdent as CFI -import GF.Formalism.Utilities -import GF.Formalism.CFG -import qualified GF.Parsing.CFG as P - -type Token = CFI.CFTok -type Name = CFI.CFFun -type Category = CFI.CFCat - -parse :: String -> CF.CF -> Category -> CF.CFParser -parse = buildParser . errVal (errVal undefined (P.parseCF "")) . P.parseCF - -buildParser :: P.CFParser Category Name Token -> CF.CF -> Category -> CF.CFParser -buildParser parser cf start tokens = (parseResults, parseInformation) - where parseInformation = prtSep "\n" trees - parseResults = [ (tree2cfTree t, []) | t <- trees ] - theInput = input tokens - edges = tracePrt "Parsing.CF - nr. edges" (prt.length) $ - parser pInf [start] theInput - chart = tracePrt "Parsing.CF - sz. chart" (prt . map (length.snd) . aAssocs) $ - grammar2chart $ map addCategory edges - forests = tracePrt "Parsing.CF - nr. forests" (prt.length) $ - chart2forests chart (const False) - [ uncurry Edge (inputBounds theInput) start ] - trees = tracePrt "Parsing.CF - nr. trees" (prt.length) $ - concatMap forest2trees forests - pInf = P.buildCFPInfo $ cf2grammar cf (nubsort tokens) - - -addCategory (CFRule cat rhs name) = CFRule cat rhs (name, cat) - -tree2cfTree (TNode (name, Edge _ _ cat) trees) = CF.CFTree (name, (cat, map tree2cfTree trees)) - -cf2grammar :: CF.CF -> [Token] -> CFGrammar Category Name Token -cf2grammar cf tokens = [ CFRule cat rhs name | - (name, (cat, rhs0)) <- cfRules, - rhs <- mapM item2symbol rhs0 ] - where cfRules = concatMap (CF.predefRules (CF.predefOfCF cf)) tokens ++ - CF.rulesOfCF cf - item2symbol (CF.CFNonterm cat) = [Cat cat] - item2symbol item = map Tok $ filter (CF.matchCFTerm item) tokens - - diff --git a/src/GF/Parsing/CFG.hs b/src/GF/Parsing/CFG.hs deleted file mode 100644 index f64ce55f1..000000000 --- a/src/GF/Parsing/CFG.hs +++ /dev/null @@ -1,51 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/11 10:28:16 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- CFG parsing ------------------------------------------------------------------------------ - -module GF.Parsing.CFG - (parseCF, module GF.Parsing.CFG.PInfo) where - -import GF.Data.Operations (Err(..)) - -import GF.Formalism.Utilities -import GF.Formalism.CFG -import GF.Parsing.CFG.PInfo - -import qualified GF.Parsing.CFG.Incremental as Inc -import qualified GF.Parsing.CFG.General as Gen - ----------------------------------------------------------------------- --- parsing - -parseCF :: (Ord n, Ord c, Ord t) => String -> Err (CFParser c n t) - -parseCF "bottomup" = Ok $ Gen.parse bottomup -parseCF "topdown" = Ok $ Gen.parse topdown - -parseCF "gb" = Ok $ Gen.parse bottomup -parseCF "gt" = Ok $ Gen.parse topdown -parseCF "ib" = Ok $ Inc.parse (bottomup, noFilter) -parseCF "it" = Ok $ Inc.parse (topdown, noFilter) -parseCF "ibFT" = Ok $ Inc.parse (bottomup, topdown) -parseCF "ibFB" = Ok $ Inc.parse (bottomup, bottomup) -parseCF "ibFTB" = Ok $ Inc.parse (bottomup, bothFilters) -parseCF "itF" = Ok $ Inc.parse (topdown, bottomup) - --- error parser: -parseCF prs = Bad $ "CFG parsing strategy not defined: " ++ prs - -bottomup = (True, False) -topdown = (False, True) -noFilter = (False, False) -bothFilters = (True, True) - - diff --git a/src/GF/Parsing/CFG/General.hs b/src/GF/Parsing/CFG/General.hs deleted file mode 100644 index 4f5959a85..000000000 --- a/src/GF/Parsing/CFG/General.hs +++ /dev/null @@ -1,103 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:08 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- CFG parsing with a general chart ------------------------------------------------------------------------------ - -module GF.Parsing.CFG.General - (parse, Strategy) where - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Formalism.Utilities -import GF.Formalism.CFG -import GF.Parsing.CFG.PInfo -import GF.Data.GeneralDeduction -import GF.Data.Assoc -import Control.Monad - -parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser c n t -parse strategy grammar start = extract . - tracePrt "Parsing.CFG.General - size internal of chart" - (prt . length . chartList) . - process strategy grammar start - --- | parsing strategy: (isBottomup, isTopdown) -type Strategy = (Bool, Bool) - -extract :: (Ord n, Ord c, Ord t) => - IChart n (Symbol c t) -> CFChart c n t -extract chart = [ CFRule (Edge j k cat) daughters name | - Edge j k (Cat cat, found, [], Just name) <- chartList chart, - daughters <- path j k (reverse found) ] - where path i k [] = [ [] | i==k ] - path i k (Tok tok : found) - = [ Tok tok : daughters | - daughters <- path (i+1) k found ] - path i k (Cat cat : found) - = [ Cat (Edge i j cat) : daughters | - Edge _i j _cat <- chartLookup chart (Passive (Cat cat) i), - daughters <- path j k found ] - - -process :: (Ord n, Ord c, Ord t) => - Strategy -- ^ (isBottomup, isTopdown) :: (Bool, Bool) - -> CFPInfo c n t -- ^ parser information (= grammar) - -> [c] -- ^ list of starting categories - -> Input t -- ^ input string - -> IChart n (Symbol c t) -process (isBottomup, isTopdown) grammar start - = trace2 "Parsing.CFG.General - strategy" ((if isBottomup then " BU" else "") ++ - (if isTopdown then " TD" else "")) $ - buildChart keyof [predict, combine] . axioms - where axioms input = initial ++ scan input - - scan input = map (fmap mkEdge) (inputEdges input) - mkEdge tok = (Tok tok, [], [], Nothing) - - -- the combine rule - combine chart (Edge j k (next, _, [], _)) - = [ edge `forwardTo` k | edge <- chartLookup chart (Active next j) ] - combine chart edge@(Edge _ j (_, _, next:_, _)) - = [ edge `forwardTo` k | Edge _ k _ <- chartLookup chart (Passive next j) ] - - -- initial predictions - initial = [ loopingEdge 0 rule | cat <- start, rule <- tdRuleLookup ? cat ] - - -- predictions - predict chart (Edge j k (next, _, [], _)) | isBottomup - = [ loopingEdge j rule `forwardTo` k | rule <- bottomupRules grammar ? next ] - -- - - - - - - - - - ^^^^^^^^^^^^^ Kilbury prediction: move dot forward - predict chart (Edge _ k (_, _, Cat cat:_, _)) - = [ loopingEdge k rule | rule <- tdRuleLookup ? cat ] - predict _ _ = [] - - tdRuleLookup | isTopdown = topdownRules grammar - | isBottomup = emptyLeftcornerRules grammar - --- internal representation of parse items - -type Item n s = Edge (s, [s], [s], Maybe n) -type IChart n s = ParseChart (Item n s) (IKey s) -data IKey s = Active s Int - | Passive s Int - deriving (Eq, Ord, Show) - -keyof (Edge _ j (_, _, next:_, _)) = Active next j -keyof (Edge j _ (cat, _, [], _)) = Passive cat j - -forwardTo (Edge i j (cat, found, next:tofind, name)) k - = Edge i k (cat, next:found, tofind, name) - -loopingEdge k (CFRule cat tofind name) = Edge k k (Cat cat, [], tofind, Just name) - - - diff --git a/src/GF/Parsing/CFG/Incremental.hs b/src/GF/Parsing/CFG/Incremental.hs deleted file mode 100644 index adab2b73c..000000000 --- a/src/GF/Parsing/CFG/Incremental.hs +++ /dev/null @@ -1,150 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:23:09 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Incremental chart parsing for CFG ------------------------------------------------------------------------------ - - -module GF.Parsing.CFG.Incremental - (parse, Strategy) where - -import GF.System.Tracing -import GF.Infra.Print - -import Data.Array - -import GF.Data.Operations -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Formalism.Utilities -import GF.Formalism.CFG -import GF.Parsing.CFG.PInfo -import GF.Data.IncrementalDeduction - - --- | parsing strategy: (predict:(BU, TD), filter:(BU, TD)) -type Strategy = ((Bool, Bool), (Bool, Bool)) - -parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser c n t -parse strategy grammar start = extract . - tracePrt "Parsing.CFG.Incremental - size of internal chart" - (prt . length . flip chartList const) . - process strategy grammar start - -extract :: (Ord n, Ord c, Ord t) => - IChart c n t -> CFChart c n t -extract finalChart = [ CFRule (Edge j k cat) daughters name | - (k, Item j (CFRule cat [] name) found) <- chartList finalChart (,), - daughters <- path j k (reverse found) ] - where path i k [] = [ [] | i==k ] - path i k (Tok tok : found) - = [ Tok tok : daughters | - daughters <- path (i+1) k found ] - path i k (Cat cat : found) - = [ Cat (Edge i j cat) : daughters | - Item j _ _ <- chartLookup finalChart i (Passive cat), - daughters <- path j k found ] - -process :: (Ord n, Ord c, Ord t) => - Strategy -> CFPInfo c n t -> [c] -> Input t -> IChart c n t -process ((isPredictBU, isPredictTD), (isFilterBU, isFilterTD)) grammar start input - = trace2 "Parsing.CFG.Incremental - strategy" ((if isPredictBU then "BU-predict " else "") ++ - (if isPredictTD then "TD-predict " else "") ++ - (if isFilterBU then "BU-filter " else "") ++ - (if isFilterTD then "TD-filter " else "")) $ - finalChart - where finalChart = buildChart keyof rules axioms $ inputBounds input - - axioms 0 = union $ map (tdInfer 0) start - axioms k = union [ buInfer j k (Tok token) | - (token, js) <- aAssocs (inputTo input ! k), j <- js ] - - rules k (Item j (CFRule cat [] _) _) - = buInfer j k (Cat cat) - rules k (Item j rule@(CFRule _ (sym@(Cat next):_) _) found) - = tdInfer k next <++> - -- hack for empty rules: - [ Item j (forward rule) (sym:found) | - emptyCategories grammar ?= next ] - rules _ _ = [] - - buInfer j k next = buPredict j k next <++> buCombine j k next - tdInfer k next = tdPredict k next - - -- the combine rule - buCombine j k next - | j == k = [] -- hack for empty rules, see rules above and tdPredict below - | otherwise = [ Item i (forward rule) (next:found) | - Item i rule found <- (finalChart ! j) ? Active next ] - - -- kilbury bottom-up prediction - buPredict j k next - = [ Item j rule [next] | isPredictBU, - rule <- map forward $ bottomupRules grammar ? next, - buFilter rule k, - tdFilter rule j k ] - - -- top-down prediction - tdPredict k cat - = [ Item k rule [] | isPredictTD || isFilterTD, - rule <- topdownRules grammar ? cat, - buFilter rule k ] <++> - -- hack for empty rules: - [ Item k rule [] | isPredictBU, - rule <- emptyLeftcornerRules grammar ? cat ] - - -- bottom up filtering: input symbol k can begin the given symbol list (first set) - -- leftcornerTokens DOESN'T WORK WITH EMPTY RULES!!! - buFilter (CFRule _ (Cat cat:_) _) k | isFilterBU - = k < snd (inputBounds input) && - hasCommonElements (leftcornerTokens grammar ? cat) - (aElems (inputFrom input ! k)) - buFilter _ _ = True - - -- top down filtering: 'cat' is reachable by an active edge ending in node j < k - tdFilter (CFRule cat _ _) j k | isFilterTD && j < k - = (tdFilters ! j) ?= cat - tdFilter _ _ _ = True - - tdFilters = listArray (inputBounds input) $ - map (listSet . limit leftCats . activeCats) [0..] - activeCats j = [ next | Active (Cat next) <- aElems (finalChart ! j) ] - leftCats cat = [ left | CFRule _cat (Cat left:_) _ <- topdownRules grammar ? cat ] - - ----------------------------------------------------------------------- --- type declarations, items & keys - -data Item c n t = Item Int (CFRule c n t) [Symbol c t] - deriving (Eq, Ord, Show) - -data IKey c t = Active (Symbol c t) | Passive c - deriving (Eq, Ord, Show) - -type IChart c n t = IncrementalChart (Item c n t) (IKey c t) - -keyof :: Item c n t -> IKey c t -keyof (Item _ (CFRule _ (next:_) _) _) = Active next -keyof (Item _ (CFRule cat [] _) _) = Passive cat - -forward :: CFRule c n t -> CFRule c n t -forward (CFRule cat (_:rest) name) = CFRule cat rest name - ----------------------------------------------------------------------- - -instance (Print n, Print c, Print t) => Print (Item c n t) where - prt (Item k rule syms) - = "<"++show k++ ": "++ prt rule++" / "++prt syms++">" - -instance (Print c, Print t) => Print (IKey c t) where - prt (Active sym) = "?" ++ prt sym - prt (Passive cat) = "!" ++ prt cat - - diff --git a/src/GF/Parsing/CFG/PInfo.hs b/src/GF/Parsing/CFG/PInfo.hs deleted file mode 100644 index f877b225e..000000000 --- a/src/GF/Parsing/CFG/PInfo.hs +++ /dev/null @@ -1,98 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:45 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- CFG parsing, parser information ------------------------------------------------------------------------------ - -module GF.Parsing.CFG.PInfo - (CFParser, CFPInfo(..), buildCFPInfo) where - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Formalism.Utilities -import GF.Formalism.CFG -import GF.Data.SortedList -import GF.Data.Assoc - ----------------------------------------------------------------------- --- type declarations - --- | the list of categories = possible starting categories -type CFParser c n t = CFPInfo c n t - -> [c] - -> Input t - -> CFChart c n t - ------------------------------------------------------------- --- parser information - -data CFPInfo c n t - = CFPInfo { grammarTokens :: SList t, - nameRules :: Assoc n (SList (CFRule c n t)), - topdownRules :: Assoc c (SList (CFRule c n t)), - bottomupRules :: Assoc (Symbol c t) (SList (CFRule c n t)), - emptyLeftcornerRules :: Assoc c (SList (CFRule c n t)), - emptyCategories :: Set c, - cyclicCategories :: SList c, - -- ^ ONLY FOR DIRECT CYCLIC RULES!!! - leftcornerTokens :: Assoc c (SList t) - -- ^ DOES NOT WORK WITH EMPTY RULES!!! - } - -buildCFPInfo :: (Ord c, Ord n, Ord t) => CFGrammar c n t -> CFPInfo c n t - --- this is not permanent... -buildCFPInfo grammar = traceCalcFirst grammar $ - tracePrt "CFG.PInfo - parser info" (prt) $ - pInfo' (filter (not . isCyclic) grammar) - -pInfo' grammar = CFPInfo grToks nmRules tdRules buRules elcRules emptyCats cyclicCats leftToks - where grToks = union [ nubsort [ tok | Tok tok <- rhs ] | - CFRule _ rhs _ <- grammar ] - nmRules = accumAssoc id [ (name, rule) | - rule@(CFRule _ _ name) <- grammar ] - tdRules = accumAssoc id [ (cat, rule) | - rule@(CFRule cat _ _) <- grammar ] - buRules = accumAssoc id [ (next, rule) | - rule@(CFRule _ (next:_) _) <- grammar ] - elcRules = accumAssoc id $ limit lc emptyRules - leftToks = accumAssoc id $ limit lc $ - nubsort [ (cat, token) | - CFRule cat (Tok token:_) _ <- grammar ] - lc (left, res) = nubsort [ (cat, res) | - CFRule cat _ _ <- buRules ? Cat left ] - emptyRules = nubsort [ (cat, rule) | - rule@(CFRule cat [] _) <- grammar ] - emptyCats = listSet $ limitEmpties $ map fst emptyRules - limitEmpties es = if es==es' then es else limitEmpties es' - where es' = nubsort [ cat | CFRule cat rhs _ <- grammar, - all (symbol (\e -> e `elem` es) (const False)) rhs ] - cyclicCats = nubsort [ cat | CFRule cat [Cat cat'] _ <- grammar, cat == cat' ] - -isCyclic (CFRule cat [Cat cat'] _) = cat==cat' -isCyclic _ = False - - ----------------------------------------------------------------------- --- pretty-printing of statistics - -instance (Ord c, Ord n, Ord t) => Print (CFPInfo c n t) where - prt pI = "[ tokens=" ++ sl grammarTokens ++ - "; names=" ++ sla nameRules ++ - "; tdCats=" ++ sla topdownRules ++ - "; buCats=" ++ sla bottomupRules ++ - "; elcCats=" ++ sla emptyLeftcornerRules ++ - "; eCats=" ++ sla emptyCategories ++ - -- "; cCats=" ++ sl cyclicCategories ++ - -- "; lctokCats=" ++ sla leftcornerTokens ++ - " ]" - where sla f = show $ length $ aElems $ f pI - sl f = show $ length $ f pI diff --git a/src/GF/Parsing/FCFG.hs b/src/GF/Parsing/FCFG.hs deleted file mode 100644 index 30a7801c8..000000000 --- a/src/GF/Parsing/FCFG.hs +++ /dev/null @@ -1,100 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- FCFG parsing ------------------------------------------------------------------------------ - -module GF.Parsing.FCFG - (parseFCF,buildFCFPInfo,FCFPInfo(..),makeFinalEdge) where - -import GF.Data.SortedList -import GF.Data.Assoc - -import GF.Infra.PrintClass - -import GF.Formalism.FCFG -import GF.Formalism.Utilities - -import qualified GF.Parsing.FCFG.Active as Active -import GF.Parsing.FCFG.PInfo - -import GF.GFCC.DataGFCC -import GF.GFCC.CId -import GF.GFCC.Macros -import GF.Data.ErrM - -import qualified Data.Map as Map - ----------------------------------------------------------------------- --- parsing - --- main parsing function - -parseFCF :: - String -> -- ^ parsing strategy - FCFPInfo -> -- ^ compiled grammar (fcfg) - CId -> -- ^ starting category - [String] -> -- ^ input tokens - Err [Exp] -- ^ resulting GF terms -parseFCF strategy pinfo startCat inString = - do let inTokens = input inString - startCats <- Map.lookup startCat (startupCats pinfo) - fcfParser <- {- trace lctree $ -} parseFCF strategy - let chart = fcfParser pinfo startCats inTokens - (i,j) = inputBounds inTokens - finalEdges = [makeFinalEdge cat i j | cat <- startCats] - forests = map cnv_forests $ chart2forests chart (const False) finalEdges - filteredForests = forests >>= applyProfileToForest - trees = nubsort $ filteredForests >>= forest2trees - return $ map tree2term trees - where - parseFCF :: String -> Err (FCFParser) - parseFCF "bottomup" = Ok $ Active.parse "b" - parseFCF "topdown" = Ok $ Active.parse "t" - parseFCF strat = Bad $ "FCFG parsing strategy not defined: " ++ strat - - -cnv_forests FMeta = FMeta -cnv_forests (FNode (Name (CId n) p) fss) = FNode (Name (CId n) (map cnv_profile p)) (map (map cnv_forests) fss) -cnv_forests (FString x) = FString x -cnv_forests (FInt x) = FInt x -cnv_forests (FFloat x) = FFloat x - -cnv_profile (Unify x) = Unify x -cnv_profile (Constant x) = Constant (cnv_forests2 x) - -cnv_forests2 FMeta = FMeta -cnv_forests2 (FNode (CId n) fss) = FNode (CId n) (map (map cnv_forests2) fss) -cnv_forests2 (FString x) = FString x -cnv_forests2 (FInt x) = FInt x -cnv_forests2 (FFloat x) = FFloat x - ----------------------------------------------------------------------- --- parse trees to GFCC terms - -tree2term :: SyntaxTree CId -> Exp -tree2term (TNode f ts) = tree (AC f) (map tree2term ts) - -tree2term (TString s) = tree (AS s) [] -tree2term (TInt n) = tree (AI n) [] -tree2term (TFloat f) = tree (AF f) [] -tree2term (TMeta) = exp0 - ----------------------------------------------------------------------- --- conversion and unification of forests - --- simplest implementation -applyProfileToForest :: SyntaxForest FName -> [SyntaxForest CId] -applyProfileToForest (FNode name@(Name fun profile) children) - | isCoercionF name = concat chForests - | otherwise = [ FNode fun chForests | not (null chForests) ] - where chForests = concat [ applyProfileM unifyManyForests profile forests | - forests0 <- children, - forests <- mapM applyProfileToForest forests0 ] -applyProfileToForest (FString s) = [FString s] -applyProfileToForest (FInt n) = [FInt n] -applyProfileToForest (FFloat f) = [FFloat f] -applyProfileToForest (FMeta) = [FMeta] diff --git a/src/GF/Parsing/FCFG/Active.hs b/src/GF/Parsing/FCFG/Active.hs deleted file mode 100644 index df55793f8..000000000 --- a/src/GF/Parsing/FCFG/Active.hs +++ /dev/null @@ -1,179 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- MCFG parsing, the active algorithm ------------------------------------------------------------------------------ - -module GF.Parsing.FCFG.Active (parse) where - -import GF.Data.GeneralDeduction -import GF.Data.Assoc -import GF.Data.SortedList -import GF.Data.Utilities - -import GF.Formalism.FCFG -import GF.Formalism.Utilities - -import GF.Infra.PrintClass - -import GF.Parsing.FCFG.Range -import GF.Parsing.FCFG.PInfo - -import Control.Monad (guard) - -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Array - ----------------------------------------------------------------------- --- * parsing - -parse :: String -> FCFParser -parse strategy pinfo starts toks = xchart2syntaxchart chart pinfo - where chart = process strategy pinfo toks axioms emptyXChart - axioms | isBU strategy = literals pinfo toks ++ initialBU pinfo toks - | isTD strategy = literals pinfo toks ++ initialTD pinfo starts toks - -isBU s = s=="b" -isTD s = s=="t" - --- used in prediction -emptyChildren :: RuleId -> FCFPInfo -> SyntaxNode RuleId RangeRec -emptyChildren ruleid pinfo = SNode ruleid (replicate (length rhs) []) - where - FRule _ rhs _ _ = allRules pinfo ! ruleid - -process :: String -> FCFPInfo -> Input FToken -> [(FCat,Item)] -> XChart FCat -> XChart FCat -process strategy pinfo toks [] chart = chart -process strategy pinfo toks ((c,item):items) chart = process strategy pinfo toks items $! univRule c item chart - where - univRule cat item@(Active found rng lbl ppos node@(SNode ruleid recs)) chart - | inRange (bounds lin) ppos = - case lin ! ppos of - FSymCat c r d -> case recs !! d of - [] -> case insertXChart chart item c of - Nothing -> chart - Just chart -> let items = do item@(Final found' _) <- lookupXChartFinal chart c - rng <- concatRange rng (found' !! r) - return (c, Active found rng lbl (ppos+1) (SNode ruleid (updateNth (const found') d recs))) - ++ - do guard (isTD strategy) - ruleid <- topdownRules pinfo ? c - return (c, Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo)) - in process strategy pinfo toks items chart - found' -> let items = do rng <- concatRange rng (found' !! r) - return (c, Active found rng lbl (ppos+1) node) - in process strategy pinfo toks items chart - FSymTok tok -> let items = do (i,j) <- inputToken toks ? tok - rng' <- concatRange rng (makeRange i j) - return (cat, Active found rng' lbl (ppos+1) node) - in process strategy pinfo toks items chart - | otherwise = - if inRange (bounds lins) (lbl+1) - then univRule cat (Active (rng:found) EmptyRange (lbl+1) 0 node) chart - else univRule cat (Final (reverse (rng:found)) node) chart - where - (FRule fn _ cat lins) = allRules pinfo ! ruleid - lin = lins ! lbl - univRule cat item@(Final found' node) chart = - case insertXChart chart item cat of - Nothing -> chart - Just chart -> let items = do (Active found rng l ppos node@(SNode ruleid _)) <- lookupXChartAct chart cat - let FRule _ _ _ lins = allRules pinfo ! ruleid - FSymCat cat r d = lins ! l ! ppos - rng <- concatRange rng (found' !! r) - return (cat, Active found rng l (ppos+1) (updateChildren node d found')) - ++ - do guard (isBU strategy) - ruleid <- leftcornerCats pinfo ? cat - let FRule _ _ _ lins = allRules pinfo ! ruleid - FSymCat cat r d = lins ! 0 ! 0 - return (cat, Active [] (found' !! r) 0 1 (updateChildren (emptyChildren ruleid pinfo) d found')) - - updateChildren :: SyntaxNode RuleId RangeRec -> Int -> RangeRec -> SyntaxNode RuleId RangeRec - updateChildren (SNode ruleid recs) i rec = SNode ruleid $! updateNth (const rec) i recs - in process strategy pinfo toks items chart - ----------------------------------------------------------------------- --- * XChart - -data Item - = Active RangeRec - Range - {-# UNPACK #-} !FIndex - {-# UNPACK #-} !FPointPos - (SyntaxNode RuleId RangeRec) - | Final RangeRec (SyntaxNode RuleId RangeRec) - deriving (Eq, Ord) - -data XChart c = XChart !(ParseChart Item c) !(ParseChart Item c) - -emptyXChart :: Ord c => XChart c -emptyXChart = XChart emptyChart emptyChart - -insertXChart (XChart actives finals) item@(Active _ _ _ _ _) c = - case chartInsert actives item c of - Nothing -> Nothing - Just actives -> Just (XChart actives finals) - -insertXChart (XChart actives finals) item@(Final _ _) c = - case chartInsert finals item c of - Nothing -> Nothing - Just finals -> Just (XChart actives finals) - -lookupXChartAct (XChart actives finals) c = chartLookup actives c -lookupXChartFinal (XChart actives finals) c = chartLookup finals c - -xchart2syntaxchart :: XChart FCat -> FCFPInfo -> SyntaxChart FName (FCat,RangeRec) -xchart2syntaxchart (XChart actives finals) pinfo = - accumAssoc groupSyntaxNodes $ - [ case node of - SNode ruleid rrecs -> let FRule fun rhs cat _ = allRules pinfo ! ruleid - in ((cat,found), SNode fun (zip rhs rrecs)) - SString s -> ((cat,found), SString s) - SInt n -> ((cat,found), SInt n) - SFloat f -> ((cat,found), SFloat f) - | (cat, Final found node) <- chartAssocs finals - ] - -literals :: FCFPInfo -> Input FToken -> [(FCat,Item)] -literals pinfo toks = - [let (c,node) = lexer t in (c,Final [makeRange i j] node) | Edge i j t <- inputEdges toks, not (t `elem` grammarToks pinfo)] - where - lexer t = - case reads t of - [(n,"")] -> (fcatInt, SInt (n::Integer)) - _ -> case reads t of - [(f,"")] -> (fcatFloat, SFloat (f::Double)) - _ -> (fcatString,SString t) - - ----------------------------------------------------------------------- --- Earley -- - --- called with all starting categories -initialTD :: FCFPInfo -> [FCat] -> Input FToken -> [(FCat,Item)] -initialTD pinfo starts toks = - do cat <- starts - ruleid <- topdownRules pinfo ? cat - return (cat,Active [] (Range 0 0) 0 0 (emptyChildren ruleid pinfo)) - - ----------------------------------------------------------------------- --- Kilbury -- - -initialBU :: FCFPInfo -> Input FToken -> [(FCat,Item)] -initialBU pinfo toks = - do (tok,rngs) <- aAssocs (inputToken toks) - ruleid <- leftcornerTokens pinfo ? tok - let FRule _ _ cat _ = allRules pinfo ! ruleid - (i,j) <- rngs - return (cat,Active [] (makeRange i j) 0 1 (emptyChildren ruleid pinfo)) - ++ - do ruleid <- epsilonRules pinfo - let FRule _ _ cat _ = allRules pinfo ! ruleid - return (cat,Active [] EmptyRange 0 0 (emptyChildren ruleid pinfo)) diff --git a/src/GF/Parsing/FCFG/Incremental.hs b/src/GF/Parsing/FCFG/Incremental.hs deleted file mode 100644 index 5ee77a061..000000000 --- a/src/GF/Parsing/FCFG/Incremental.hs +++ /dev/null @@ -1,107 +0,0 @@ -module GF.Parsing.FCFG.Incremental where
-
-import Data.Array
-import qualified Data.Map as Map
-import qualified Data.IntMap as IntMap
-import qualified Data.Set as Set
-import Control.Monad
-
-import GF.Data.Assoc
-import GF.Data.GeneralDeduction
-import GF.Formalism.FCFG
-import GF.Formalism.Utilities
-import GF.Parsing.FCFG.PInfo
-import GF.Parsing.FCFG.Range
-import GF.GFCC.CId
-import Debug.Trace
-
-initState :: FCFPInfo -> CId -> State
-initState pinfo start =
- let items = do
- starts <- Map.lookup start (startupCats pinfo)
- c <- starts
- ruleid <- topdownRules pinfo ? c
- let (FRule fn args cat lins) = allRules pinfo ! ruleid
- lbl <- indices lins
- return (Active 0 lbl 0 ruleid args cat)
-
- forest = IntMap.fromListWith Set.union [(cat, Set.singleton (Passive ruleid args)) | (ruleid, FRule _ args cat _) <- assocs (allRules pinfo)]
-
- max_fid = case IntMap.maxViewWithKey forest of
- Just ((fid,_), _) -> fid+1
- Nothing -> 0
-
- in process pinfo items (State emptyChart [] emptyChart Map.empty forest max_fid 0)
-
-nextState :: FCFPInfo -> FToken -> State -> State
-nextState pinfo t state =
- process pinfo (chartLookup (tokens state) t) state{ chart=emptyChart
- , charts=chart state : charts state
- , tokens=emptyChart
- , passive=Map.empty
- , currOffset=currOffset state+1
- }
-
-getCompletions :: State -> FToken -> [FToken]
-getCompletions state w =
- [t | t <- chartKeys (tokens state), take (length w) t == w]
-
-process pinfo [] state = state
-process pinfo (item@(Active j lbl ppos ruleid args fid0):xitems) state
- | inRange (bounds lin) ppos =
- case lin ! ppos of
- FSymCat _ r d -> let fid = args !! d
- in case chartInsert (chart state) item (fid,r) of
- Nothing -> process pinfo xitems state
- Just actCat -> let items = do exprs <- IntMap.lookup fid (forest state)
- (Passive ruleid args) <- Set.toList exprs
- return (Active k r 0 ruleid args fid)
- `mplus`
- do id <- Map.lookup (fid,r,k) (passive state)
- return (Active j lbl (ppos+1) ruleid (updateAt d id args) fid0)
- in process pinfo (xitems++items) state{chart=actCat}
- FSymTok tok -> case chartInsert (tokens state) (Active j lbl (ppos+1) ruleid args fid0) tok of
- Nothing -> process pinfo xitems state
- Just actTok -> process pinfo xitems state{tokens=actTok}
- | otherwise = case Map.lookup (fid0, lbl, j) (passive state) of
- Nothing -> let fid = nextId state
- items = do Active j' lbl ppos ruleid args fidc <- chartLookup ((chart state:charts state) !! (k-j)) (fid0,lbl)
- let FSymCat _ _ d = rhs ruleid lbl ! ppos
- return (Active j' lbl (ppos+1) ruleid (updateAt d fid args) fidc)
- in process pinfo (xitems++items) state{passive=Map.insert (fid0, lbl, j) fid (passive state)
- ,forest =IntMap.insert fid (Set.singleton (Passive ruleid args)) (forest state)
- ,nextId =nextId state+1
- }
- Just id -> process pinfo xitems state{forest = IntMap.insertWith Set.union id (Set.singleton (Passive ruleid args)) (forest state)}
- where
- lin = rhs ruleid lbl
- k = currOffset state
-
- rhs ruleid lbl = lins ! lbl
- where
- (FRule _ _ cat lins) = allRules pinfo ! ruleid
-
- updateAt nr x xs = [if i == nr then x else y | (i,y) <- zip [0..] xs]
-
-
-data Active
- = Active Int FIndex FPointPos RuleId [FCat] FCat
- deriving (Eq,Show,Ord)
-data Passive
- = Passive RuleId [FCat]
- deriving (Eq,Ord,Show)
-
-
-data State
- = State
- { chart :: Chart
- , charts :: [Chart]
- , tokens :: ParseChart Active FToken
- , passive :: Map.Map (FCat, FIndex, Int) FCat
- , forest :: IntMap.IntMap (Set.Set Passive)
- , nextId :: FCat
- , currOffset :: Int
- }
- deriving Show
-
-type Chart = ParseChart Active (FCat, FIndex)
diff --git a/src/GF/Parsing/FCFG/PInfo.hs b/src/GF/Parsing/FCFG/PInfo.hs deleted file mode 100644 index 8b288f2f1..000000000 --- a/src/GF/Parsing/FCFG/PInfo.hs +++ /dev/null @@ -1,121 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- FCFG parsing, parser information ------------------------------------------------------------------------------ - -module GF.Parsing.FCFG.PInfo where - -import GF.Infra.PrintClass -import GF.Formalism.Utilities -import GF.Formalism.FCFG -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Parsing.FCFG.Range -import qualified GF.GFCC.CId as AbsGFCC - -import Data.Array -import Data.Maybe -import qualified Data.Map as Map -import qualified Data.Set as Set -import Debug.Trace - ----------------------------------------------------------------------- --- type declarations - --- | the list of categories = possible starting categories -type FCFParser = FCFPInfo - -> [FCat] - -> Input FToken - -> SyntaxChart FName (FCat,RangeRec) - -makeFinalEdge cat 0 0 = (cat, [EmptyRange]) -makeFinalEdge cat i j = (cat, [makeRange i j]) - ------------------------------------------------------------- --- parser information - -type RuleId = Int - -data FCFPInfo - = FCFPInfo { allRules :: Array RuleId FRule - , topdownRules :: Assoc FCat (SList RuleId) - -- ^ used in 'GF.Parsing.MCFG.Active' (Earley): - -- , emptyRules :: [RuleId] - , epsilonRules :: [RuleId] - -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): - , leftcornerCats :: Assoc FCat (SList RuleId) - , leftcornerTokens :: Assoc FToken (SList RuleId) - -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): - , grammarCats :: SList FCat - , grammarToks :: SList FToken - , startupCats :: Map.Map AbsGFCC.CId [FCat] - } - - -getLeftCornerTok lins - | inRange (bounds syms) 0 = case syms ! 0 of - FSymTok tok -> Just tok - _ -> Nothing - | otherwise = Nothing - where - syms = lins ! 0 - -getLeftCornerCat lins - | inRange (bounds syms) 0 = case syms ! 0 of - FSymCat c _ _ -> Just c - _ -> Nothing - | otherwise = Nothing - where - syms = lins ! 0 - -buildFCFPInfo :: FGrammar -> FCFPInfo -buildFCFPInfo (grammar,startup) = -- trace (unlines [prt (x,Set.toList set) | (x,set) <- Map.toList leftcornFilter]) $ - FCFPInfo { allRules = allrules - , topdownRules = topdownrules - -- , emptyRules = emptyrules - , epsilonRules = epsilonrules - , leftcornerCats = leftcorncats - , leftcornerTokens = leftcorntoks - , grammarCats = grammarcats - , grammarToks = grammartoks - , startupCats = startup - } - - where allrules = listArray (0,length grammar-1) grammar - topdownrules = accumAssoc id [(cat, ruleid) | (ruleid, FRule _ _ cat _) <- assocs allrules] - -- emptyrules = [ruleid | (ruleid, FRule _ [] _ _) <- assocs allrules] - epsilonrules = [ ruleid | (ruleid, FRule _ _ _ lins) <- assocs allrules, - not (inRange (bounds (lins ! 0)) 0) ] - leftcorncats = accumAssoc id - [ (fromJust (getLeftCornerCat lins), ruleid) | - (ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerCat lins) ] - leftcorntoks = accumAssoc id - [ (fromJust (getLeftCornerTok lins), ruleid) | - (ruleid, FRule _ _ _ lins) <- assocs allrules, isJust (getLeftCornerTok lins) ] - grammarcats = aElems topdownrules - grammartoks = nubsort [t | (FRule _ _ _ lins) <- grammar, lin <- elems lins, FSymTok t <- elems lin] - -fcfPInfoToFGrammar :: FCFPInfo -> FGrammar -fcfPInfoToFGrammar pinfo = (elems (allRules pinfo), startupCats pinfo) - ----------------------------------------------------------------------- --- pretty-printing of statistics - -instance Print FCFPInfo where - prt pI = "[ allRules=" ++ sl (elems . allRules) ++ - "; tdRules=" ++ sla topdownRules ++ - -- "; emptyRules=" ++ sl emptyRules ++ - "; epsilonRules=" ++ sl epsilonRules ++ - "; lcCats=" ++ sla leftcornerCats ++ - "; lcTokens=" ++ sla leftcornerTokens ++ - "; categories=" ++ sl grammarCats ++ - " ]" - - where sl f = show $ length $ f pI - sla f = let (as, bs) = unzip $ aAssocs $ f pI - in show (length as) ++ "/" ++ show (length (concat bs)) - diff --git a/src/GF/Parsing/FCFG/Range.hs b/src/GF/Parsing/FCFG/Range.hs deleted file mode 100644 index 24674f58b..000000000 --- a/src/GF/Parsing/FCFG/Range.hs +++ /dev/null @@ -1,50 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : Krasimir Angelov --- Stability : (stable) --- Portability : (portable) --- --- Definitions of ranges, and operations on ranges ------------------------------------------------------------------------------ - -module GF.Parsing.FCFG.Range - ( RangeRec, Range(..), makeRange, concatRange, rangeEdge, edgeRange, minRange, maxRange, - ) where - - --- GF modules -import GF.Formalism.Utilities -import GF.Infra.PrintClass - ------------------------------------------------------------- --- ranges as single pairs - -type RangeRec = [Range] - -data Range = Range {-# UNPACK #-} !Int {-# UNPACK #-} !Int - | EmptyRange - deriving (Eq, Ord) - -makeRange :: Int -> Int -> Range -makeRange = Range - -concatRange :: Range -> Range -> [Range] -concatRange EmptyRange rng = return rng -concatRange rng EmptyRange = return rng -concatRange (Range i j) (Range j' k) = [Range i k | j==j'] - -rangeEdge :: a -> Range -> Edge a -rangeEdge a (Range i j) = Edge i j a - -edgeRange :: Edge a -> Range -edgeRange (Edge i j _) = Range i j - -minRange :: Range -> Int -minRange (Range i j) = i - -maxRange :: Range -> Int -maxRange (Range i j) = j - -instance Print Range where - prt (Range i j) = "(" ++ show i ++ "-" ++ show j ++ ")" - prt (EmptyRange) = "(?)" diff --git a/src/GF/Parsing/GFC.hs b/src/GF/Parsing/GFC.hs deleted file mode 100644 index 9f1328a50..000000000 --- a/src/GF/Parsing/GFC.hs +++ /dev/null @@ -1,208 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/13 12:40:19 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.9 $ --- --- The main parsing module, parsing GFC grammars --- by translating to simpler formats, such as PMCFG and CFG ----------------------------------------------------------------------- - -module GF.Parsing.GFC - (parse, PInfo(..), buildPInfo) where - -import GF.System.Tracing -import GF.Infra.Print -import qualified GF.Grammar.PrGrammar as PrGrammar - -import GF.Data.ErrM - -import qualified GF.Grammar.Grammar as Grammar -import qualified GF.Grammar.Macros as Macros -import qualified GF.Canon.AbsGFC as AbsGFC -import qualified GF.GFCC.DataGFCC as AbsGFCC -import GF.GFCC.CId -import qualified GF.Infra.Ident as Ident -import GF.CF.CFIdent (CFCat, cfCat2Ident, CFTok, wordsCFTok, prCFTok) - -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Formalism.Utilities -import GF.Conversion.Types - -import qualified GF.Formalism.GCFG as G -import qualified GF.Formalism.SimpleGFC as S -import qualified GF.Formalism.MCFG as M -import GF.Formalism.FCFG -import qualified GF.Formalism.CFG as C -import qualified GF.Parsing.MCFG as PM -import qualified GF.Parsing.FCFG as PF -import qualified GF.Parsing.CFG as PC - ----------------------------------------------------------------------- --- parsing information - -data PInfo = PInfo { mcfPInfo :: MCFPInfo - , fcfPInfo :: PF.FCFPInfo - , cfPInfo :: CFPInfo - } - -type MCFPInfo = PM.MCFPInfo MCat Name MLabel Token -type CFPInfo = PC.CFPInfo CCat Name Token - -buildPInfo :: MGrammar -> FGrammar -> CGrammar -> PInfo -buildPInfo mcfg fcfg cfg = PInfo { mcfPInfo = PM.buildMCFPInfo mcfg - , fcfPInfo = PF.buildFCFPInfo fcfg - , cfPInfo = PC.buildCFPInfo cfg - } - -instance Print PInfo where - prt (PInfo m f c) = prt m ++ "\n" ++ prt c - ----------------------------------------------------------------------- --- main parsing function - -parse :: String -- ^ parsing algorithm (mcfg or cfg) - -> String -- ^ parsing strategy - -> PInfo -- ^ compiled grammars (mcfg and cfg) - -> Ident.Ident -- ^ abstract module name - -> CFCat -- ^ starting category - -> [CFTok] -- ^ input tokens - -> Err [Grammar.Term] -- ^ resulting GF terms - - --- parsing via CFG -parse "c" strategy pinfo abs startCat inString - = do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $ - inputMany (map wordsCFTok inString) - let startCats = tracePrt "Parsing.GFC - starting CF categories" prt $ - filter isStart $ map fst $ aAssocs $ PC.topdownRules cfpi - isStart cat = ccat2scat cat == cfCat2Ident startCat - cfpi = cfPInfo pinfo - cfParser <- PC.parseCF strategy - let cfChart = tracePrt "Parsing.GFC - CF chart" (prt . length) $ - cfParser cfpi startCats inTokens - chart = tracePrt "Parsing.GFC - chart" (prt . map (length.snd) . aAssocs) $ - C.grammar2chart cfChart - finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $ - map (uncurry Edge (inputBounds inTokens)) startCats - forests = chart2forests chart (const False) finalEdges - traceM "Parsing.GFC - nr. unfiltered forests" (prt (length forests)) - traceM "Parsing.GFC - nr. unfiltered trees" (prt (length (forests >>= forest2trees))) - let filteredForests = tracePrt "Parsing.GFC - nr. forests" (prt . length) $ - forests >>= applyProfileToForest - -- compactFs = tracePrt "#compactForests" (prt . length) $ - -- tracePrt "compactForests" (prtBefore "\n") $ - -- compactForests forests - trees = tracePrt "Parsing.GFC - nr. trees" (prt . length) $ - nubsort $ filteredForests >>= forest2trees - -- compactFs >>= forest2trees - return $ map (tree2term abs) trees - - --- parsing via MCFG -parse "m" strategy pinfo abs startCat inString - = do let inTokens = tracePrt "Parsing.GFC - input tokens" prt $ - inputMany (map wordsCFTok inString) - let startCats = tracePrt "Parsing.GFC - starting MCF categories" prt $ - filter isStart $ PM.grammarCats mcfpi - isStart cat = mcat2scat cat == cfCat2Ident startCat - mcfpi = mcfPInfo pinfo - mcfParser <- PM.parseMCF strategy - let chart = mcfParser mcfpi startCats inTokens - finalEdges = tracePrt "Parsing.GFC - final chart edges" prt $ - [ PM.makeFinalEdge cat lbl (inputBounds inTokens) | - cat@(MCat _ [lbl]) <- startCats ] - forests = chart2forests chart (const False) finalEdges - traceM "Parsing.GFC - nr. unfiltered forests" (prt (length forests)) - traceM "Parsing.GFC - nr. unfiltered trees" (prt (length (forests >>= forest2trees))) - let filteredForests = tracePrt "Parsing.GFC - nr. forests" (prt . length) $ - forests >>= applyProfileToForest - -- compactFs = tracePrt "#compactForests" (prt . length) $ - -- tracePrt "compactForests" (prtBefore "\n") $ - -- compactForests forests - trees = tracePrt "Parsing.GFC - nr. trees" (prt . length) $ - nubsort $ filteredForests >>= forest2trees - -- compactFs >>= forest2trees - return $ map (tree2term abs) trees - - --- parsing via FCFG -parse "f" strategy pinfo abs startCat inString = - let Ident.IC x = cfCat2Ident startCat - cat' = CId x - in case PF.parseFCF strategy (fcfPInfo pinfo) cat' (map prCFTok inString) of - Ok es -> Ok (map (exp2term abs) es) - Bad msg -> Bad msg - - --- error parser: -selectParser prs strategy _ _ _ = Bad $ "Parser '" ++ prs ++ "' not defined with strategy: " ++ strategy - -cnv_forests FMeta = FMeta -cnv_forests (FNode (Name (CId n) p) fss) = FNode (Name (Ident.IC n) (map cnv_profile p)) (map (map cnv_forests) fss) -cnv_forests (FString x) = FString x -cnv_forests (FInt x) = FInt x -cnv_forests (FFloat x) = FFloat x - -cnv_profile (Unify x) = Unify x -cnv_profile (Constant x) = Constant (cnv_forests2 x) - -cnv_forests2 FMeta = FMeta -cnv_forests2 (FNode (CId n) fss) = FNode (Ident.IC n) (map (map cnv_forests2) fss) -cnv_forests2 (FString x) = FString x -cnv_forests2 (FInt x) = FInt x -cnv_forests2 (FFloat x) = FFloat x - ----------------------------------------------------------------------- --- parse trees to GF terms - -tree2term :: Ident.Ident -> SyntaxTree Fun -> Grammar.Term -tree2term abs (TNode f ts) = Macros.mkApp (Macros.qq (abs,f)) (map (tree2term abs) ts) -tree2term abs (TString s) = Macros.string2term s -tree2term abs (TInt n) = Macros.int2term n -tree2term abs (TFloat f) = Macros.float2term f -tree2term abs (TMeta) = Macros.mkMeta 0 - -exp2term :: Ident.Ident -> AbsGFCC.Exp -> Grammar.Term -exp2term abs (AbsGFCC.DTr _ a es) = ---- TODO: bindings - Macros.mkApp (atom2term abs a) (map (exp2term abs) es) - -atom2term :: Ident.Ident -> AbsGFCC.Atom -> Grammar.Term -atom2term abs (AbsGFCC.AC (CId f)) = Macros.qq (abs,Ident.IC f) -atom2term abs (AbsGFCC.AS s) = Macros.string2term s -atom2term abs (AbsGFCC.AI n) = Macros.int2term n -atom2term abs (AbsGFCC.AF f) = Macros.float2term f -atom2term abs (AbsGFCC.AM i) = Macros.mkMeta (fromInteger i) - ----------------------------------------------------------------------- --- conversion and unification of forests - --- simplest implementation -applyProfileToForest :: SyntaxForest Name -> [SyntaxForest Fun] -applyProfileToForest (FNode name@(Name fun profile) children) - | isCoercion name = concat chForests - | otherwise = [ FNode fun chForests | not (null chForests) ] - where chForests = concat [ applyProfileM unifyManyForests profile forests | - forests0 <- children, - forests <- mapM applyProfileToForest forests0 ] -applyProfileToForest (FString s) = [FString s] -applyProfileToForest (FInt n) = [FInt n] -applyProfileToForest (FFloat f) = [FFloat f] -applyProfileToForest (FMeta) = [FMeta] - -{- --- more intelligent(?) implementation -applyProfileToForest (FNode (Name name profile) children) - | isCoercion name = concat chForests - | otherwise = [ FNode name chForests | not (null chForests) ] - where chForests = concat [ mapM (checkProfile forests) profile | - forests0 <- children, - forests <- mapM applyProfileToForest forests0 ] --} - - diff --git a/src/GF/Parsing/MCFG.hs b/src/GF/Parsing/MCFG.hs deleted file mode 100644 index bda3af675..000000000 --- a/src/GF/Parsing/MCFG.hs +++ /dev/null @@ -1,68 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/11 10:28:16 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- MCFG parsing ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG - (parseMCF, module GF.Parsing.MCFG.PInfo) where - -import GF.Data.Operations (Err(..)) - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Parsing.MCFG.PInfo - -import qualified GF.Parsing.MCFG.Naive as Naive -import qualified GF.Parsing.MCFG.Active as Active -import qualified GF.Parsing.MCFG.FastActive as FastActive --- 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 - -parseMCF :: (Ord c, Ord n, Ord l, Ord t) => String -> Err (MCFParser c n l t) -parseMCF prs | prs `elem` strategies = Ok $ parseMCF' prs - | otherwise = Bad $ "MCFG parsing strategy not defined: " ++ prs - - -strategies = words "bottomup topdown n an ab at i rn ran rab rat ri ft fb" - - -parseMCF' :: (Ord c, Ord n, Ord l, Ord t) => String -> MCFParser c n l t - -parseMCF' "bottomup" pinfo starts toks = parseMCF' "fb" pinfo starts toks -parseMCF' "topdown" pinfo starts toks = parseMCF' "ft" pinfo starts toks - -parseMCF' "n" pinfo starts toks = Naive.parse pinfo starts toks -parseMCF' "an" pinfo starts toks = Active.parse "n" pinfo starts toks -parseMCF' "ab" pinfo starts toks = Active.parse "b" pinfo starts toks -parseMCF' "at" pinfo starts toks = Active.parse "t" pinfo starts toks -parseMCF' "i" pinfo starts toks = Incremental.parse pinfo starts toks - --- parseMCF' "an2" pinfo starts toks = Active2.parse "n" pinfo starts toks --- parseMCF' "ab2" pinfo starts toks = Active2.parse "b" pinfo starts toks --- parseMCF' "at2" pinfo starts toks = Active2.parse "t" pinfo starts toks --- parseMCF' "i2" pinfo starts toks = Incremental2.parse pinfo starts toks - -parseMCF' "rn" pinfo starts toks = Naive.parseR (rrP pinfo toks) starts -parseMCF' "ran" pinfo starts toks = Active.parseR "n" (rrP pinfo toks) starts -parseMCF' "rab" pinfo starts toks = Active.parseR "b" (rrP pinfo toks) starts -parseMCF' "rat" pinfo starts toks = Active.parseR "t" (rrP pinfo toks) starts -parseMCF' "ri" pinfo starts toks = Incremental.parseR (rrP pinfo toks) starts ntoks - where ntoks = snd (inputBounds toks) - -parseMCF' "fb" pinfo starts toks = FastActive.parse "b" (rrP pinfo toks) starts -parseMCF' "ft" pinfo starts toks = FastActive.parse "t" (rrP pinfo toks) starts - -rrP pi = rangeRestrictPInfo pi diff --git a/src/GF/Parsing/MCFG/Active.hs b/src/GF/Parsing/MCFG/Active.hs deleted file mode 100644 index c6e9c6b06..000000000 --- a/src/GF/Parsing/MCFG/Active.hs +++ /dev/null @@ -1,318 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- MCFG parsing, the active algorithm ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Active (parse, parseR) 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 = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ] - where chart = process strategy pinfo starts toks - --- parseR :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t -parseR strategy pinfo starts = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - 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) => - String -> MCFPInfo c n l t -> [c] -> Input t -> AChart c n l -process strategy pinfo starts toks - = tracePrt "MCFG.Active - chart size" prtSizes $ - buildChart keyof (complete : combine : convert : rules) axioms - where rules | isNil strategy = [scan] - | isBU strategy = [scan, predictKilbury pinfo toks] - | isTD strategy = [scan, predictEarley pinfo toks] - axioms | isNil strategy = predict pinfo toks - | isBU strategy = {- terminal pinfo toks ++ -} initialScan pinfo 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" -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) => 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 + epsilon rules" (prt . length) $ - do tok <- aElems (inputToken toks) - Rule abs (Cnc _ _ lins) <- - leftcornerTokens pinfo ? tok ++ - epsilonRules pinfo - 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)) ++ - epsilonRules 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 AChart c n l = ParseChart (Item c n l) (AKey c) - -data Item c n l = Active (Abstract c n) - (RangeRec l) - Range - (Lin c l Range) - (LinRec c l Range) - [RangeRec l] - | Final (Abstract c n) (RangeRec l) [RangeRec l] - | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -data AKey c = Act c - | Pass c - | Useless - | Fin - deriving (Eq, Ord, Show) - - -keyof :: Item c n l -> AKey c -keyof (Active _ _ _ (Lin _ (Cat (next, _, _):_)) _ _) = Act next -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 ]) ++ - ", 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 (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 (AKey c) where - prt (Act c) = "Active " ++ prt c - prt (Pass c) = "Passive " ++ prt c - prt (Fin) = "Final" - prt (Useless) = "Useless" diff --git a/src/GF/Parsing/MCFG/Active2.hs b/src/GF/Parsing/MCFG/Active2.hs deleted file mode 100644 index 7ad8627bc..000000000 --- a/src/GF/Parsing/MCFG/Active2.hs +++ /dev/null @@ -1,237 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ --- --- MCFG parsing, the active algorithm (alternative version) ------------------------------------------------------------------------------ - -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 = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - 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" diff --git a/src/GF/Parsing/MCFG/FastActive.hs b/src/GF/Parsing/MCFG/FastActive.hs deleted file mode 100644 index 0a8e24b55..000000000 --- a/src/GF/Parsing/MCFG/FastActive.hs +++ /dev/null @@ -1,176 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- MCFG parsing, the active algorithm, optimized version --- structure stolen from Krasimir Angelov's GF.Parsing.FCFG.Active ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.FastActive (parse) where - -import GF.Data.GeneralDeduction -import GF.Data.Assoc -import GF.Data.Utilities - -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities - -import GF.Infra.Ident - -import GF.Parsing.MCFG.Range -import GF.Parsing.MCFG.PInfo - -import GF.System.Tracing - -import Control.Monad (guard) - -import GF.Infra.Print - -import qualified Data.List as List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Array - ----------------------------------------------------------------------- --- * parsing - --- parse :: (Ord c, Ord n, Ord l, Ord t) => String -> MCFParser c n l t -parse strategy pinfo starts = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - Final (Abs cat rhs fun) found rrecs <- listXChartFinal chart ] - where chart = process strategy pinfo axioms emptyXChart - - -- axioms | isBU strategy = terminal pinfo toks ++ initialScan pinfo toks - axioms | isBU strategy = initialBU pinfo - | isTD strategy = initialTD pinfo starts - -isBU s = s=="b" -isTD s = s=="t" - --- used in prediction -emptyChildren :: Abstract c n -> [RangeRec l] -emptyChildren (Abs _ rhs _) = replicate (length rhs) [] - -updateChildren :: Eq l => [RangeRec l] -> Int -> RangeRec l -> [[RangeRec l]] -updateChildren recs i rec = updateNthM update i recs - where update rec' = do guard (null rec' || rec' == rec) - return rec - -process :: (Ord c, Ord n, Ord l) => String -> MCFPInfo c n l Range -> [Item c n l] -> XChart c n l -> XChart c n l -process strategy pinfo [] chart = chart -process strategy pinfo (item:items) chart = process strategy pinfo items $! univRule item chart - where - univRule item@(Active abs found rng (Lin l syms) lins recs) chart - = case syms of - Cat(c,r,d) : syms' -> - case insertXChart chart item c of - Nothing -> chart - Just chart -> - let items = -- predict topdown - [ Active abs [] EmptyRange lin lins (emptyChildren abs) | - isTD strategy, - Rule abs (Cnc _ _ (lin:lins)) <- topdownRules pinfo ? c ] ++ - - -- combine - [ Active abs found rng'' (Lin l syms') lins recs' | - Final _ found' _ <- lookupXChartFinal chart c, - rng' <- projection r found', - rng'' <- concatRange rng rng', - recs' <- updateChildren recs d found' ] - in process strategy pinfo items chart - - -- scan - Tok rng' : syms' -> - let items = [ Active abs found rng'' (Lin l syms') lins recs | - rng'' <- concatRange rng rng' ] - in process strategy pinfo items chart - - -- complete - [] -> case lins of - (lin':lins') -> univRule (Active abs ((l,rng):found) EmptyRange lin' lins' recs) chart - [] -> univRule (Final abs (reverse ((l,rng):found)) recs) chart - - univRule item@(Final abs@(Abs cat _ _) found' recs) chart = - case insertXChart chart item cat of - Nothing -> chart - Just chart -> - let items = -- predict bottomup - [ Active abs [] rng (Lin l syms') lins children | - isBU strategy, - Rule abs (Cnc _ _ (Lin l (Cat(c,r,d):syms') : lins)) <- leftcornerCats pinfo ? cat, - -- lin' : lins' <- rangeRestRec toks (Lin l syms' : lins), - rng <- projection r found', - children <- unifyRec (emptyChildren abs) d found' ] ++ - - -- combine - [ Active abs found rng'' (Lin l syms') lins recs' | - Active abs found rng (Lin l (Cat(c,r,d):syms')) lins recs <- lookupXChartAct chart cat, - rng' <- projection r found', - rng'' <- concatRange rng rng', - recs' <- updateChildren recs d found' ] - in process strategy pinfo items chart - ----------------------------------------------------------------------- --- * XChart - -data XChart c n l = XChart !(AChart c n l) !(AChart c n l) -type AChart c n l = ParseChart (Item c n l) c - -data Item c n l = Active (Abstract c n) - (RangeRec l) - Range - (Lin c l Range) - (LinRec c l Range) - [RangeRec l] - | Final (Abstract c n) (RangeRec l) [RangeRec l] --- | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -emptyXChart :: (Ord c, Ord n, Ord l) => XChart c n l -emptyXChart = XChart emptyChart emptyChart - -insertXChart (XChart actives finals) item@(Active _ _ _ _ _ _) c = - case chartInsert actives item c of - Nothing -> Nothing - Just actives -> Just (XChart actives finals) - -insertXChart (XChart actives finals) item@(Final _ _ _) c = - case chartInsert finals item c of - Nothing -> Nothing - Just finals -> Just (XChart actives finals) - -lookupXChartAct (XChart actives finals) c = chartLookup actives c -lookupXChartFinal (XChart actives finals) c = chartLookup finals c - -listXChartAct (XChart actives finals) = chartList actives -listXChartFinal (XChart actives finals) = chartList finals - - ----------------------------------------------------------------------- --- Earley -- - --- called with all starting categories -initialTD :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [c] -> [Item c n l] -initialTD pinfo starts = - [ Active abs [] (Range (0, 0)) lin' lins' (emptyChildren abs) | - cat <- starts, - Rule abs (Cnc _ _ (lin':lins')) <- topdownRules pinfo ? cat ] - -- lin' : lins' <- rangeRestRec toks lins - - ----------------------------------------------------------------------- --- Kilbury -- - -initialBU :: (Ord c, Ord n, Ord l) => MCFPInfo c n l Range -> [Item c n l] -initialBU pinfo = - [ Active abs [] EmptyRange lin' lins' (emptyChildren abs) | - -- do tok <- aElems (inputToken toks) - Rule abs (Cnc _ _ (lin':lins')) <- - concatMap snd (aAssocs (leftcornerTokens pinfo)) ++ - -- leftcornerTokens pinfo ? tok ++ - epsilonRules pinfo ] - -- lin' : lins' <- rangeRestRec toks lins diff --git a/src/GF/Parsing/MCFG/Incremental.hs b/src/GF/Parsing/MCFG/Incremental.hs deleted file mode 100644 index bd5b4114d..000000000 --- a/src/GF/Parsing/MCFG/Incremental.hs +++ /dev/null @@ -1,178 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.4 $ --- --- MCFG parsing, the incremental algorithm ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Incremental (parse, parseR) where - -import Data.List -import Control.Monad (guard) - -import GF.Data.Utilities (select) -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 GF.Infra.Print - ----------------------------------------------------------------------- --- parsing - -parse :: (Ord n, Ord c, Ord l, Ord t) => MCFParser c n l t -parse pinfo starts toks = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - 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 = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - 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 _ _ _ = [] - - -predict :: (Ord n, Ord c, Ord l, Ord t) => MCFPInfo c n l t -> Input t -> Int -> [Item c n l] -predict pinfo toks n = - tracePrt "MCFG.Incremental - predicted rules" (prt . length) $ - do Rule abs@(Abs _ rhs _) (Cnc _ _ lins) <- rulesMatchingInput pinfo toks - 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 - - -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) - Range - (Lin c l Range) - (LinRec c l Range) - [RangeRec l] - | Final (Abstract c n) (RangeRec l) [RangeRec l] --- | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -data IKey c l = Act c l Int - | Pass c l Int - | Useless - | Fin - deriving (Eq, Ord, Show) - -keyof :: Item c n l -> IKey c l -keyof (Active _ _ rng (Lin _ (Cat (next,lbl,_):_)) _ _) - = Act next lbl (maxRange rng) -keyof (Active (Abs cat _ _) found rng (Lin lbl []) _ _) - = Pass cat lbl (minRange rng) -keyof (Final _ _ _) = Fin -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 ]) ++ - ", useless=" ++ show (length (chartLookup chart Useless)) - -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" diff --git a/src/GF/Parsing/MCFG/Incremental2.hs b/src/GF/Parsing/MCFG/Incremental2.hs deleted file mode 100644 index db6c3084e..000000000 --- a/src/GF/Parsing/MCFG/Incremental2.hs +++ /dev/null @@ -1,157 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- MCFG parsing, the incremental algorithm (alternative version) ------------------------------------------------------------------------------ - -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 = - accumAssoc groupSyntaxNodes $ - [ ((cat, found), SNode fun (zip rhs rrecs)) | - 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" diff --git a/src/GF/Parsing/MCFG/Naive.hs b/src/GF/Parsing/MCFG/Naive.hs deleted file mode 100644 index 7d1fa0a8a..000000000 --- a/src/GF/Parsing/MCFG/Naive.hs +++ /dev/null @@ -1,142 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- MCFG parsing, the naive algorithm ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Naive (parse, parseR) where - -import Control.Monad (guard) - --- GF modules -import GF.Data.GeneralDeduction -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities -import GF.Parsing.MCFG.Range -import GF.Parsing.MCFG.PInfo -import GF.Data.SortedList -import GF.Data.Assoc -import GF.System.Tracing - -import GF.Infra.Print - ----------------------------------------------------------------------- --- * parsing - --- | Builds a chart from the initial agenda, given by prediction, and the inference rules -parse :: (Ord t, Ord n, Ord c, Ord l) => MCFParser c n l t -parse pinfo starts toks - = accumAssoc groupSyntaxNodes $ - [ ((cat, makeRangeRec lins), SNode fun (zip rhs rrecs)) | - Active (Abs cat _Nil fun, rhs) lins rrecs <- chartLookup chart Final ] - where chart = process pinfo toks - --- | Builds a chart from the initial agenda, given by prediction, and the inference rules --- parseR :: (Ord t, Ord n, Ord c, Ord l) => MCFParser c n l t -parseR pinfo starts - = accumAssoc groupSyntaxNodes $ - [ ((cat, makeRangeRec lins), SNode fun (zip rhs rrecs)) | - 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 $ - 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 NChart c n l = ParseChart (Item c n l) (NKey c) - -data Item c n l = Active (DottedRule c n) (LinRec c l Range) [RangeRec l] - | Passive c (RangeRec l) - deriving (Eq, Ord, Show) - -type DottedRule c n = (Abstract c n, [c]) - -data NKey c = Act c - | Pass c - | Final - deriving (Eq, Ord, Show) - -keyof :: Item c n l -> NKey c -keyof (Active (Abs _ (next:_) _, _) _ _) = Act next -keyof (Passive cat _) = Pass cat -keyof _ = Final - --- for tracing purposes -prtSizes chart = "final=" ++ show (length (chartLookup chart Final)) ++ - ", passive=" ++ show (sum [length (chartLookup chart k) | - k@(Pass _) <- chartKeys chart ]) ++ - ", active=" ++ show (sum [length (chartLookup chart k) | - k@(Act _) <- chartKeys chart ]) - -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, cs) lrec rrecs) = "? " ++ prt abs ++ " . " ++ prtSep " " cs ++ ";\n\t" ++ - "{" ++ prtSep " " lrec ++ "}" ++ - ( if null rrecs then ";" else ";\n\t" ++ - "{" ++ prtSep "} {" (map (prtSep " ") rrecs) ++ "}" ) - prt (Passive c rrec) = "- " ++ prt c ++ "; {" ++ prtSep " " rrec ++ "}" - -instance Print c => Print (NKey c) where - prt (Act c) = "Active " ++ prt c - prt (Pass c) = "Passive " ++ prt c - prt (Final) = "Final" - - diff --git a/src/GF/Parsing/MCFG/PInfo.hs b/src/GF/Parsing/MCFG/PInfo.hs deleted file mode 100644 index 56119dcec..000000000 --- a/src/GF/Parsing/MCFG/PInfo.hs +++ /dev/null @@ -1,162 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/13 12:40:19 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- MCFG parsing, parser information ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.PInfo where - -import GF.System.Tracing -import GF.Infra.Print - -import GF.Formalism.Utilities -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Data.SortedList -import GF.Data.Assoc -import GF.Parsing.MCFG.Range - ----------------------------------------------------------------------- --- type declarations - --- | the list of categories = possible starting categories -type MCFParser c n l t = MCFPInfo c n l t - -> [c] - -> Input t - -> SyntaxChart n (c, RangeRec l) - -makeFinalEdge :: c -> l -> (Int, Int) -> (c, RangeRec l) -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): - , epsilonRules :: [MCFRule c n l t] - -- ^ used in 'GF.Parsing.MCFG.Active' (Kilbury): - , 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) - , epsilonRules = rrRules (epsilonRules 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 - , epsilonRules = epsilonrules - , 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 ] - epsilonrules = [ rule | rule@(Rule _ (Cnc _ _ (Lin _ [] : _))) <- 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 ++ - "; epsilonRules=" ++ sl epsilonRules ++ - "; 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)) - diff --git a/src/GF/Parsing/MCFG/Range.hs b/src/GF/Parsing/MCFG/Range.hs deleted file mode 100644 index 91671fa00..000000000 --- a/src/GF/Parsing/MCFG/Range.hs +++ /dev/null @@ -1,206 +0,0 @@ ---------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.5 $ --- --- Definitions of ranges, and operations on ranges ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.Range - ( Range(..), makeRange, concatRange, rangeEdge, edgeRange, minRange, maxRange, - LinRec, RangeRec, - makeRangeRec, rangeRestRec, rangeRestrictRule, - projection, unifyRec, substArgRec - ) where - - --- Haskell -import Data.List -import Control.Monad - --- GF modules -import GF.Formalism.GCFG -import GF.Formalism.MCFG -import GF.Formalism.Utilities -import GF.Infra.Print -import GF.Data.Assoc ((?)) -import GF.Data.Utilities (updateNthM) - ------------------------------------------------------------- --- ranges as single pairs - -data Range = Range (Int, Int) - | EmptyRange - deriving (Eq, Ord, Show) - -makeRange :: (Int, Int) -> Range -concatRange :: Range -> Range -> [Range] -rangeEdge :: a -> Range -> Edge a -edgeRange :: Edge a -> Range -minRange :: Range -> Int -maxRange :: Range -> Int - -makeRange = Range -concatRange EmptyRange rng = return rng -concatRange rng EmptyRange = return rng -concatRange (Range(i,j)) (Range(j',k)) = [ Range(i,k) | j==j'] -rangeEdge a (Range(i,j)) = Edge i j a -edgeRange (Edge i j _) = Range (i,j) -minRange (Range rho) = fst rho -maxRange (Range rho) = snd rho - -instance Print Range where - prt (Range (i,j)) = "(" ++ show i ++ "-" ++ show j ++ ")" - prt (EmptyRange) = "(?)" - -{-- Types -------------------------------------------------------------------- - Linearization- and Range records implemented as lists ------------------------------------------------------------------------------} - -type LinRec c l t = [Lin c l t] - -type RangeRec l = [(l, Range)] - - -{-- Functions ---------------------------------------------------------------- - Concatenation : Concatenation of Ranges, Symbols and Linearizations - and records of Linearizations - Record transformation : Makes a Range record from a fully instantiated - Linearization record - Record projection : Given a label, returns the corresponding Range - Range restriction : Range restriction of Tokens, Symbols, - Linearizations and Records given a list of Tokens - Record replacment : Substitute a record for another in a list of Range - records - Argument substitution : Substitution of a Cat c to a Tok Range, where - Range is the cover of c - Note: The argument is still a Symbol c Range - Subsumation : Checks if a Range record subsumes another Range - record - Record unification : Unification of two Range records ------------------------------------------------------------------------------} - - ---- Concatenation ------------------------------------------------------------ - - -concSymbols :: [Symbol c Range] -> [[Symbol c Range]] -concSymbols (Tok rng:Tok rng':toks) = do rng'' <- concatRange rng rng' - concSymbols (Tok rng'':toks) -concSymbols (sym:syms) = do syms' <- concSymbols syms - return (sym:syms') -concSymbols [] = return [] - - -concLin :: Lin c l Range -> [Lin c l Range] -concLin (Lin lbl syms) = do syms' <- concSymbols syms - return (Lin lbl syms') - - -concLinRec :: LinRec c l Range -> [LinRec c l Range] -concLinRec = mapM concLin - - ---- Record transformation ---------------------------------------------------- - -makeRangeRec :: LinRec c l Range -> RangeRec l -makeRangeRec lins = map convLin lins - where convLin (Lin lbl [Tok rng]) = (lbl, rng) - convLin (Lin lbl []) = (lbl, EmptyRange) - convLin _ = error "makeRangeRec" - - ---- Record projection -------------------------------------------------------- - -projection :: Ord l => l -> RangeRec l -> [Range] -projection l rec = maybe (fail "projection") return $ lookup l rec - - ---- Range restriction -------------------------------------------------------- - -rangeRestTok :: Ord t => Input t -> t -> [Range] -rangeRestTok toks tok = do rng <- inputToken toks ? tok - return (makeRange rng) - - -rangeRestSym :: Ord t => Input t -> Symbol a t -> [Symbol a Range] -rangeRestSym toks (Tok tok) = do rng <- rangeRestTok toks tok - return (Tok rng) -rangeRestSym _ (Cat c) = return (Cat c) - - -rangeRestLin :: Ord t => Input t -> Lin c l t -> [Lin c l Range] -rangeRestLin toks (Lin lbl syms) = do syms' <- mapM (rangeRestSym toks) syms - concLin (Lin lbl syms') - -- return (Lin lbl syms') - - -rangeRestRec :: Ord t => Input t -> LinRec c l t -> [LinRec c l Range] -rangeRestRec toks = mapM (rangeRestLin toks) - - -rangeRestrictRule :: Ord t => Input t -> MCFRule c n l t -> [MCFRule c n l Range] -rangeRestrictRule toks (Rule abs (Cnc l ls lins)) = liftM (Rule abs . Cnc l ls) $ - rangeRestRec toks lins - ---- Argument substitution ---------------------------------------------------- - -substArgSymbol :: Ord l => Int -> RangeRec l -> Symbol (c, l, Int) Range - -> Symbol (c, l, Int) Range -substArgSymbol i rec tok@(Tok rng) = tok -substArgSymbol i rec cat@(Cat (c, l, j)) - | i==j = maybe err Tok $ lookup l rec - | otherwise = cat - where err = error "substArg: Label not in range-record" - -substArgLin :: Ord l => Int -> RangeRec l -> Lin c l Range - -> [Lin c l Range] -substArgLin i rec (Lin lbl syms) = - concLin (Lin lbl (map (substArgSymbol i rec) syms)) - - -substArgRec :: Ord l => Int -> RangeRec l -> LinRec c l Range - -> [LinRec c l Range] -substArgRec i rec lins = mapM (substArgLin i rec) lins - - --- 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 - -subsumes :: Ord l => RangeRec l -> RangeRec l -> Bool -subsumes rec rec' = and [r `elem` rec' | r <- rec] --- subsumes rec rec' = all (`elem` rec') rec - - -{- ---- Record unification ------------------------------------------------------- -unifyRangeRecs :: Ord l => [RangeRec l] -> [RangeRec l] -> [[RangeRec l]] -unifyRangeRecs recs recs' = zipWithM unify recs recs' - where unify :: Ord l => RangeRec l -> RangeRec l -> [RangeRec l] - unify rec [] = return rec - unify [] rec = return rec - unify rec1'@(p1@(l1, r1):rec1) rec2'@(p2@(l2, r2):rec2) - = case compare l1 l2 of - LT -> do rec3 <- unify rec1 rec2' - return (p1:rec3) - GT -> do rec3 <- unify rec1' rec2 - return (p2:rec3) - EQ -> do guard (r1 == r2) - rec3 <- unify rec1 rec2 - return (p1:rec3) --} diff --git a/src/GF/Parsing/MCFG/ViaCFG.hs b/src/GF/Parsing/MCFG/ViaCFG.hs deleted file mode 100644 index 9204ea9f1..000000000 --- a/src/GF/Parsing/MCFG/ViaCFG.hs +++ /dev/null @@ -1,186 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/08/08 09:01:25 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.4 $ --- --- MCFG parsing, through context-free approximation ------------------------------------------------------------------------------ - -module GF.Parsing.MCFG.ViaCFG where - - --- Haskell modules -import Data.List -import Control.Monad - --- GF modules -import ConvertMCFGtoDecoratedCFG -import qualified DecoratedCFParser as CFP -import qualified DecoratedGrammar as CFG -import Examples -import GF.OldParsing.GeneralChart -import qualified GF.OldParsing.MCFGrammar as MCFG -import MCFParser -import Nondet -import Parser -import GF.Parsing.MCFG.Range - - -{-- Datatypes ----------------------------------------------------------------- -Chart -Item -Key - - - Item : Four different Items are used. PreMCFG for MCFG Pre Items, Pre are - the Items returned by the pre-Functions and Mark are the - corresponding Items for the mark-Functions. For convenience correctly - marked Mark Items are converted to Passive Items. -I use dottedrule for convenience to keep track of wich daughter's RangeRec to look for. - AChart: A RedBlackMap with Items and Keys - AKey : -------------------------------------------------------------------------------} - ---Ev ta bort några typer av Item och bara nyckla på det som är unikt för den typen... -data Item n c l = PreMCFG (n, c) (RangeRec l) [RangeRec l] - | Pre (n, c) (RangeRec l) [l] [RangeRec l] - | Mark (n, c) (RangeRec l) (RangeRec l) [RangeRec l] - | Passive (n, c) (RangeRec l) (RangeRec l) - deriving (Eq, Ord, Show) - -type AChart n c l = ParseChart (Item n c l) (AKey n c l) - -data AKey n c l = Pr (n, c) l - | Pm (n, c) l - | Mk (RangeRec l) - | Ps (RangeRec l) - | Useless - deriving (Eq, Ord, Show) - - -{-- Parsing ------------------------------------------------------------------- - recognize: - parse : The Agenda consists of the Passive Items from context-free - approximation (as PreMCFG Items) and the Pre Items inferred by - pre-prediction. - keyof : Given an Item returns an appropriate Key for the Chart -------------------------------------------------------------------------------} - -recognize strategy mcfg toks = chartMember (parse strategy mcfg toks) - (Passive ("f", S) - [("s" , MCFG.Range (0, n))] - [("p" , MCFG.Range (0, n2)), ("q", MCFG.Range (n2, n))]) - (Ps [("s" , MCFG.Range (0, n))]) - where n = length toks - n2 = n `div` 2 - - ---parse :: (Ord n, Ord NT, Ord String, Eq t) => CFP.Strategy -> MCFG.Grammar n NT String t -> [t] --- -> AChart n NT String -parse strategy mcfg toks - = buildChart keyof - [preCombine, markPredict, markCombine, convert] - (makePreItems (CFP.parse strategy (CFG.pInfo (convertGrammar mcfg)) [(S, "s")] toks) ++ - (prePredict mcfg)) - - -keyof :: Item n c l -> AKey n c l -keyof (PreMCFG head [(lbl, rng)] _) = Pm head lbl -keyof (Pre head _ (lbl:lbls) _) = Pr head lbl -keyof (Mark _ _ _ (rec:recs)) = Mk rec -keyof (Passive _ rec _) = Ps rec -keyof _ = Useless - - -{-- Initializing agenda ------------------------------------------------------- - makePreItems: -------------------------------------------------------------------------------} - -makePreItems :: (Eq c, Ord i) => CFG.Grammar n (Edge (c, l)) i t -> [Item n c l] -makePreItems cfchart - = [ PreMCFG (fun, cat) [(lbl, MCFG.makeRange (i, j))] (symToRec beta) | - CFG.Rule (Edge i j (cat,lbl)) beta fun <- cfchart ] - - -prePredict :: (Ord n, Ord c, Ord l) => MCFG.Grammar n c l t -> [Item n c l] -prePredict mcfg = - [ Pre (f, nt) [] (getLables lins) (replicate (nrOfCats (head lins)) []) | - MCFG.Rule nt nts lins f <- mcfg ] - - -{-- Inference rules --------------------------------------------------------- - prePredict : - preCombine : - markPredict: - markCombine: - convert : -----------------------------------------------------------------------------} - -preCombine :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) - -> Item n c l -> [Item n c l] -preCombine chart (Pre head rec (l:ls) recs) = - [ Pre head (rec ++ [(l, r)]) ls recs'' | - PreMCFG head [(l, r)] recs' <- chartLookup chart (Pm head l), - recs'' <- solutions (unifyRangeRecs recs recs') ] -preCombine chart (PreMCFG head [(l, r)] recs) = - [ Pre head (rec ++ [(l, r)]) ls recs'' | - Pre head rec (l:ls) recs' <- chartLookup chart (Pr head l), - recs'' <- solutions (unifyRangeRecs recs recs') ] -preCombine _ _ = [] - - -markPredict :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) - -> Item n c l -> [Item n c l] -markPredict _ (Pre (n, c) rec [] recs) = [Mark (n, c) rec [] recs] -markPredict _ _ = [] - - -markCombine :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) - -> Item n c l -> [Item n c l] -markCombine chart (Mark (f, c) rec mRec (r:recs)) = - [ Mark (f, c) rec (mRec ++ r) recs | - Passive _ r _ <- chartLookup chart (Ps r)] -markCombine chart (Passive _ r _) = - [ Mark (f, c) rec (mRec++r) recs | - Mark (f, c) rec mRec (r:recs) <- chartLookup chart (Mk r) ] -markCombine _ _ = [] - - -convert :: (Ord n, Ord c, Ord l) => ParseChart (Item n c l) (AKey n c l) - -> Item n c l -> [Item n c l] -convert _ (Mark (f, c) r rec []) = [Passive (f, c) r rec] -convert _ _ = [] - - -{-- Help functions ---------------------------------------------------------------- - getRHS : - getLables: - symToRec : -----------------------------------------------------------------------------------} - --- FULKOD ! -nrOfCats :: Eq c => MCFG.Lin c l t -> Int -nrOfCats (MCFG.Lin l syms) = length $ nub [(c, i) | Cat (c, l, i) <- syms] - - --- -getLables :: LinRec c l t -> [l] -getLables lins = [l | MCFG.Lin l syms <- lins] - - --- -symToRec :: Ord i => [Symbol (Edge (c, l), i) d] -> [[(l, MCFG.Range)]] -symToRec beta = map makeLblRng $ groupBy (\(_, d) (_, d') -> (d == d')) - $ sortBy sBd [(Edge i j (c, l) , d) | Cat (Edge i j (c, l), d) - <- beta] - where makeLblRng edges = [(l, (MCFG.makeRange (i, j))) | (Edge i j (_, l), _) - <- edges] - sBd (_, d) (_, d') - | d < d' = LT - | d > d' = GT - | otherwise = EQ |
