forked from GitHub/gf-core
GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3
This commit is contained in:
aarne
178
src-3.0/GF/Parsing/MCFG/Incremental.hs
Normal file
178
src-3.0/GF/Parsing/MCFG/Incremental.hs
Normal file
@@ -0,0 +1,178 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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"
|
||||
Reference in New Issue
Block a user