gf-core/src/GF/Parsing/FCFG/Active.hs

----------------------------------------------------------------------
-- |
-- Maintainer  : Krasimir Angelov
-- Stability   : (stable)
-- Portability : (portable)
--
-- MCFG parsing, the active algorithm
-----------------------------------------------------------------------------

module GF.Parsing.FCFG.Active (parse) where

import GF.Data.GeneralDeduction
import GF.Data.Assoc
import GF.Data.Utilities

import GF.Formalism.GCFG
import GF.Formalism.FCFG
import GF.Formalism.MCFG(Lin(..))
import GF.Formalism.Utilities

import GF.Infra.Ident

import GF.Parsing.FCFG.Range
import GF.Parsing.FCFG.PInfo

import Control.Monad (guard)

import qualified Data.List as List
import qualified Data.Map  as Map
import qualified Data.Set  as Set
import Data.Array

----------------------------------------------------------------------
-- * parsing

parse :: (Ord c, Ord n, Ord t) => String -> FCFParser c n t
parse strategy pinfo starts toks =
    [ Abs (cat, found) (zip rhs rrecs) fun |
      Final ruleid found rrecs <- listXChartFinal chart,
      let FRule (Abs cat rhs fun) _ = allRules pinfo ! ruleid ]
    where chart = process strategy pinfo toks axioms emptyXChart
    
          axioms | isBU  strategy = initialBU pinfo toks
		 | isTD  strategy = initialTD pinfo starts toks

isBU  s = s=="b"
isTD  s = s=="t"

-- used in prediction
emptyChildren :: Abstract c n -> [RangeRec]
emptyChildren (Abs _ rhs _) = replicate (length rhs) []

updateChildren :: [RangeRec] -> Int -> RangeRec -> [[RangeRec]]
updateChildren recs i rec = updateNthM update i recs
    where update rec' = do guard (null rec' || rec' == rec)
                           return rec

makeMaxRange (Range _ j) = Range j j
makeMaxRange EmptyRange  = EmptyRange

process :: (Ord c, Ord n, Ord t) => String -> FCFPInfo c n t -> Input t -> [Item] -> XChart c -> XChart c
process strategy pinfo toks []           chart = chart
process strategy pinfo toks (item:items) chart = process strategy pinfo toks items $! univRule item chart
  where
    univRule item@(Active ruleid found rng lbl ppos recs) chart
      | inRange (bounds lin) ppos =
           case lin ! ppos of
             FSymCat c r d -> case insertXChart chart item c of
	                        Nothing    -> chart
	                        Just chart -> let items = do Final _ found' _ <- lookupXChartFinal chart c
	         			                     rng'  <- concatRange rng (found' !! r)
	         			                     recs' <- updateChildren recs d found'
	     			                             return (Active ruleid found rng' lbl (ppos+1) recs')
	     			                          ++
	     			                          do guard (isTD strategy)
	     			                             ruleid <- topdownRules pinfo ? c
	     			                             let FRule abs lins = allRules pinfo ! ruleid
	     			                             return (Active ruleid [] EmptyRange 0 0 (emptyChildren abs))
	     			              in process strategy pinfo toks items chart
	     FSymTok tok   -> let items = do (i,j) <- inputToken toks ? tok
	                                     rng' <- concatRange rng (makeRange i j)
	                                     return (Active ruleid found rng' lbl (ppos+1) recs)
                              in process strategy pinfo toks items chart
      | otherwise =
           if inRange (bounds lins) (lbl+1)
             then univRule (Active ruleid (rng:found)           EmptyRange (lbl+1) 0 recs) chart
             else univRule (Final  ruleid (reverse (rng:found))                      recs) chart
      where
        (FRule (Abs cat _ fn) lins) = allRules pinfo ! ruleid
        lin            = lins ! lbl
    univRule item@(Final ruleid found' recs) chart =
      case insertXChart chart item cat of
        Nothing    -> chart
        Just chart -> let items = do (Active ruleid found rng l ppos recs) <- lookupXChartAct chart cat
                                     let FRule _ lins    = allRules pinfo ! ruleid
                                         FSymCat cat r d = lins ! l ! ppos
                                     rng'  <- concatRange rng (found' !! r)
                                     recs' <- updateChildren recs d found'
                                     return (Active ruleid found rng' l (ppos+1) recs')
                                  ++
    			          do guard (isBU strategy)
			             ruleid <- leftcornerCats pinfo ? cat
			             let FRule abs lins = allRules pinfo ! ruleid
			                 FSymCat cat r d = lins ! 0 ! 0
                                     return (Active ruleid [] (found' !! r) 0 1 (updateNth (const found') d (emptyChildren abs)))
                      in process strategy pinfo toks items chart
      where
        (FRule (Abs cat _ fn) _) = allRules pinfo ! ruleid

----------------------------------------------------------------------
-- * XChart

data Item
  = Active {-# UNPACK #-} !RuleId
           RangeRec
           Range
           {-# UNPACK #-} !FLabel
           {-# UNPACK #-} !FPointPos
           [RangeRec]
  | Final {-# UNPACK #-} !RuleId RangeRec [RangeRec]
  deriving (Eq, Ord)

data XChart c = XChart !(ParseChart Item c) !(ParseChart Item c)

emptyXChart :: Ord c => XChart c
emptyXChart = XChart emptyChart emptyChart

insertXChart (XChart actives finals) item@(Active _ _ _ _ _ _) c = 
  case chartInsert actives item c of
    Nothing      -> Nothing
    Just actives -> Just (XChart actives finals)

insertXChart (XChart actives finals) item@(Final _ _ _)       c =
  case chartInsert finals item c of
    Nothing     -> Nothing
    Just finals -> Just (XChart actives finals)

lookupXChartAct   (XChart actives finals) c = chartLookup actives c
lookupXChartFinal (XChart actives finals) c = chartLookup finals  c

listXChartAct   (XChart actives finals) = chartList actives
listXChartFinal (XChart actives finals) = chartList finals


----------------------------------------------------------------------
-- Earley --

-- called with all starting categories
initialTD :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> [c] -> Input t -> [Item]
initialTD pinfo starts toks = 
    do cat <- starts
       ruleid <- topdownRules pinfo ? cat
       let FRule abs lins = allRules pinfo ! ruleid
       return $ Active ruleid [] (Range 0 0) 0 0 (emptyChildren abs)


----------------------------------------------------------------------
-- Kilbury --

-- terminal :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> Input t -> [Item]
-- terminal pinfo toks = $
--     tracePrt "MCFG.Active (Kilbury) - initial terminal rules" (prt . length) $
--     do ruleid <- emptyRules pinfo
--        let FRule abs lins = allRules pinfo ! ruleid
--        rrec <- mapM (rangeRestSyms toks EmptyRange . elems) (elems lins)
--        return $ Final ruleid rrec []
--     where
--       rangeRestSyms toks rng []                 = return rng
--       rangeRestSyms toks rng (FSymTok tok:syms) = do (i,j) <- inputToken toks ? tok
--                                                      rng' <- concatRange rng (makeRange i j)
--                                                      rangeRestSyms toks rng' syms

initialBU :: (Ord c, Ord n, Ord t) => FCFPInfo c n t -> Input t -> [Item]
initialBU pinfo toks =
    do tok <- aElems (inputToken toks)
       ruleid <- leftcornerTokens pinfo ? tok ++
                 epsilonRules pinfo
       let FRule abs lins = allRules pinfo ! ruleid
       return $ Active ruleid [] EmptyRange 0 0 (emptyChildren abs)