1 files changed, 215 insertions, 97 deletions

diff --git a/src/GF/Parsing/MCFG/Active.hs b/src/GF/Parsing/MCFG/Active.hs
index 44661b0c9..cb1440e24 100644
--- a/src/GF/Parsing/MCFG/Active.hs
+++ b/src/GF/Parsing/MCFG/Active.hs
@@ -1,81 +1,76 @@
 
-module GF.Parsing.MCFG.Active (parse) where
+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 mcfg starts toks
-    = [ Abs (cat, found) (zip rhs rrecs) fun |
-	Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ]
-    where chart = process strategy mcfg starts toks
+--parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t
+parse strategy pinfo starts toks =
+    trace2 "MCFG.Active - strategy" (if isBU strategy then "BU"
+				     else if isTD strategy then "TD" else "None") $
+    [ Abs (cat, found) (zip rhs rrecs) fun |
+      Final (Abs cat rhs fun) found rrecs <- chartLookup chart Fin ]
+    where chart = process strategy pinfo starts toks
+
+--parse :: (Ord n, Ord c, Ord l, Ord t) => String -> MCFParser c n l t
+parseR strategy pinfo starts =
+    trace2 "MCFG.Active Range - strategy" (if isBU strategy then "BU"
+					   else if isTD strategy then "TD" else "None") $
+    [ Abs (cat, found) (zip rhs rrecs) fun |
+      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 -> MCFGrammar c n l t -> [c] -> Input t -> AChart c n l
-process strategy mcfg starts toks 
-    = trace2 "MCFG.Active - strategy" (if isBU strategy then "BU"
-				       else if isTD strategy then "TD" else "None") $
-      tracePrt "MCFG.Active - chart size" prtSizes $
+	   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 = [predictKilbury mcfg toks]
-		 | isTD  strategy = [predictEarley mcfg toks]
-	  axioms | isNil strategy = predict mcfg toks
-		 | isBU  strategy = terminal mcfg toks
-		 | isTD  strategy = initial mcfg starts toks
+		 | 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"
 
-----------------------------------------------------------------------
--- * 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
-
--- to be used in prediction
+-- used in prediction
 emptyChildren :: Abstract c n -> [RangeRec l]
 emptyChildren (Abs _ rhs _) = replicate (length rhs) []
 
--- 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)) 
+makeMaxRange (Range (_, j)) = Range (j, j)
+makeMaxRange EmptyRange     = EmptyRange
 
 
 ----------------------------------------------------------------------
@@ -97,21 +92,20 @@ 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 (Active rule found rng (Lin l (Cat (c, r, d):syms)) lins recs) =
-    do Passive _c found' <- chartLookup chart (Pass c)
-       rng' <- projection r found'
-       rng'' <- concatRange rng rng'
-       guard $ subsumes (recs !! d) found' 
-       return $ Active rule found rng'' (Lin l syms) lins (replaceRec recs d found') 
+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 Active rule found' rng' (Lin l ((Cat (_c, r, d)):syms)) lins recs' 
-           <- chartLookup chart (Act c)
-       rng'' <- projection r found
-       rng <- concatRange rng' rng''
-       guard $ subsumes (recs' !! d) found
-       return $ Active rule found' rng (Lin l syms) lins (replaceRec recs' d 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]
@@ -121,66 +115,190 @@ convert _ (Final (Abs cat _ _) found _) =
     return $ Passive cat found
 convert _ _ = []
 
+
 ----------------------------------------------------------------------
 -- Naive --
 
--- | Creates an Active Item of every Rule in the Grammar to give the initial Agenda
-predict :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> Input t -> [Item c n l]
-predict grammar toks = 
-    do Rule abs (Cnc _ _ lins) <- grammar
-       (lin':lins') <- rangeRestRec toks lins 
-       return $ Active abs [] EmptyRange lin' lins' (emptyChildren abs)
+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) => MCFGrammar c n l t -> [c] -> Input t -> [Item c n l]
-initial mcfg starts toks = 
-    do Rule abs@(Abs cat _ _) (Cnc _ _ lins) <- mcfg
-       guard $ cat `elem` starts
+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)
 
--- earley prediction
-predictEarley :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> Input t
+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 mcfg toks _ (Active _ _ rng (Lin _ (Cat (cat,_,_):_)) _ _) = 
-    do rule@(Rule (Abs cat' _ _) _) <- mcfg
-       guard $ cat == cat' 
-       predEar toks rng rule 
+predictEarley pinfo toks _ item@(Active (Abs _ _ f) _ rng (Lin _ (Cat (cat,_,_):_)) _ _) = 
+    topdownRules pinfo ? cat >>= predictEarley2 toks rng 
 predictEarley _ _ _ _ = []
 
-predEar :: (Ord c, Ord n, Ord l, Ord t) => 
-	   Input t -> Range -> MCFRule c n l t -> [Item c n l]
-predEar toks _ (Rule abs@(Abs _ [] _) (Cnc _ _ lins)) = 
+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') []
-predEar toks rng (Rule abs (Cnc _ _ lins)) =
+predictEarley2 toks rng (Rule abs (Cnc _ _ lins)) =
     do lin' : lins' <- rangeRestRec toks lins 
-       return $ Active abs [] (makeMaxRange rng) lin' lins' (emptyChildren abs)
+       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)
 
-makeMaxRange (Range (_, j)) = Range (j, j)
-makeMaxRange EmptyRange     = EmptyRange
 
 ----------------------------------------------------------------------
 -- Kilbury --
 
-terminal :: (Ord c, Ord n, Ord l, Ord t) => MCFGrammar c n l t -> Input t -> [Item c n l]
-terminal mcfg toks = 
-    do Rule abs@(Abs _ [] _) (Cnc _ _ lins) <- mcfg
+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') []
 
--- kilbury prediction
-predictKilbury :: (Ord c, Ord n, Ord l, Ord t) => 
-		  MCFGrammar c n l t -> Input t
+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" (prt . length) $
+    do tok <- aElems (inputToken toks)
+       Rule abs (Cnc _ _ lins) <- leftcornerTokens pinfo ? tok
+       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 mcfg toks _ (Passive cat found) = 
-    do Rule abs@(Abs _ rhs _) (Cnc _ _ (Lin l (Cat (cat', r, i):syms) : lins)) <- mcfg
-       guard $ cat == cat'
+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
-       let children = replaceRec (emptyChildren abs) i 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))
+       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"