mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-14 05:32:51 -06:00
remove all files that aren't used in GF-3.0
This commit is contained in:
kr.angelov
@@ -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
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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
|
||||
@@ -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)
|
||||
@@ -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 ]
|
||||
-}
|
||||
|
||||
|
||||
@@ -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
|
||||
@@ -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"
|
||||
@@ -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"
|
||||
@@ -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
|
||||
@@ -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"
|
||||
@@ -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"
|
||||
@@ -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"
|
||||
|
||||
|
||||
@@ -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))
|
||||
|
||||
@@ -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)
|
||||
-}
|
||||
@@ -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
|
||||
Reference in New Issue
Block a user