From b96b36f43de3e2f8b58d5f539daa6f6d47f25870 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 25 Jun 2008 16:43:48 +0000 Subject: removed src for 2.9 --- src/GF/Parsing/FCFG/Active.hs | 179 ------------------------------------- src/GF/Parsing/FCFG/Incremental.hs | 107 ---------------------- src/GF/Parsing/FCFG/PInfo.hs | 121 ------------------------- src/GF/Parsing/FCFG/Range.hs | 50 ----------- 4 files changed, 457 deletions(-) delete mode 100644 src/GF/Parsing/FCFG/Active.hs delete mode 100644 src/GF/Parsing/FCFG/Incremental.hs delete mode 100644 src/GF/Parsing/FCFG/PInfo.hs delete mode 100644 src/GF/Parsing/FCFG/Range.hs (limited to 'src/GF/Parsing/FCFG') 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) = "(?)" -- cgit v1.2.3