----------------------------------------------------------------------
-- |
-- 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"