"Committed_by_peb"

2 files changed, 225 insertions, 0 deletions

diff --git a/src/GF/OldParsing/ParseCFG/General.hs b/src/GF/OldParsing/ParseCFG/General.hs
new file mode 100644
index 000000000..7ac395ba3
--- /dev/null
+++ b/src/GF/OldParsing/ParseCFG/General.hs
@@ -0,0 +1,83 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ParseCFG.General
+-- Maintainer  : Peter Ljunglöf
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:57 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Several implementations of CFG chart parsing
+-----------------------------------------------------------------------------
+
+module GF.OldParsing.ParseCFG.General 
+    (parse, Strategy) where
+
+import GF.System.Tracing
+
+import GF.OldParsing.Utilities
+import GF.OldParsing.CFGrammar
+import GF.OldParsing.GeneralChart 
+import GF.Data.Assoc
+
+parse :: (Ord n, Ord c, Ord t) => Strategy -> CFParser n c t
+parse strategy grammar start = extract . process strategy grammar start
+
+type Strategy = (Bool, Bool) -- (isBottomup, isTopdown)
+
+extract :: [Item n (Symbol c t)] -> [Edge (Rule n c t)]
+extract edges =
+    edges'
+    where edges' = [ Edge j k (Rule cat (reverse found) name) |
+		     Edge j k (Cat cat, found, [], Just name) <- edges ]
+
+process :: (Ord n, Ord c, Ord t) => Strategy -> PInfo n c t -> 
+	   [c] -> Input t -> [Item n (Symbol c t)]
+process (isBottomup, isTopdown) grammar start
+    = trace2 "CFParserGeneral" ((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 = Chart (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 (Rule cat tofind name) = Edge k k (Cat cat, [], tofind, Just name)
+
+
+
diff --git a/src/GF/OldParsing/ParseCFG/Incremental.hs b/src/GF/OldParsing/ParseCFG/Incremental.hs
new file mode 100644
index 000000000..882fad26e
--- /dev/null
+++ b/src/GF/OldParsing/ParseCFG/Incremental.hs
@@ -0,0 +1,142 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ParseCFG.Incremental
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:57 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Incremental chart parsing for context-free grammars
+-----------------------------------------------------------------------------
+
+ 
+
+module GF.OldParsing.ParseCFG.Incremental 
+    (parse, Strategy) where
+
+import GF.System.Tracing
+import GF.Printing.PrintParser
+
+-- haskell modules:
+import Array
+-- gf modules:
+import GF.Data.SortedList
+import GF.Data.Assoc
+import Operations
+-- parser modules:
+import GF.OldParsing.Utilities
+import GF.OldParsing.CFGrammar
+import GF.OldParsing.IncrementalChart
+
+
+type Strategy = ((Bool, Bool), (Bool, Bool)) -- (predict:(BU, TD), filter:(BU, TD))
+
+parse :: (Ord n, Ord c, Ord t, Show t) => 
+	 Strategy -> CFParser n c t
+parse ((isPredictBU, isPredictTD), (isFilterBU, isFilterTD)) grammar start input =
+    trace2 "CFParserIncremental" 
+	       ((if isPredictBU then "BU-predict " else "") ++
+		(if isPredictTD then "TD-predict " else "") ++
+		(if isFilterBU  then "BU-filter " else "") ++
+		(if isFilterTD  then "TD-filter " else "")) $
+    finalEdges
+    where finalEdges = [ Edge j k (Rule cat (reverse found) name) |
+			 (k, state) <- 
+			   tracePrt "#passiveChart"
+			   (prt . map (length . (?Passive) . snd)) $
+			   tracePrt "#activeChart" 
+			   (prt . map (length . concatMap snd . aAssocs . snd)) $
+			   assocs finalChart,
+			 Item j (Rule cat _Nil name) found <- state ? Passive ]
+
+	  finalChart = buildChart keyof rules axioms $ inputBounds input
+
+          axioms 0 = --tracePrt ("axioms 0") (prtSep "\n") $
+		     union $ map (tdInfer 0) start
+	  axioms k = --tracePrt ("axioms "++show k) (prtSep "\n") $
+		     union [ buInfer j k (Tok token) |
+			     (token, js) <- aAssocs (inputTo input ! k), j <- js ]
+
+          rules k (Item j (Rule cat [] _) _)
+	      = buInfer j k (Cat cat)
+          rules k (Item j rule@(Rule _ (Cat next:_) _) found) 
+	      = tdInfer k next <++> 
+	        -- hack for empty rules:
+		[ Item j (forward rule) (Cat next:found) | 
+		  emptyCategories grammar ?= next ]
+	  rules _ _ = []
+
+          buInfer j k next = --tracePrt ("buInfer "++show(j,k)++" "++prt next) (prtSep "\n") $
+			     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
+	      | 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 $ --tracePrt ("buRules "++prt next) (prtSep "\n") $
+		                        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 (Rule _ (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 (Rule 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 | Rule _cat (Cat left:_) _ <- topdownRules grammar ? cat ]
+
+
+-- type declarations, items & keys
+data Item n c t = Item Int (Rule n c t) [Symbol c t]
+		  deriving (Eq, Ord, Show)
+
+data IKey   c t = Active (Symbol c t) | Passive
+		  deriving (Eq, Ord, Show)
+
+keyof :: Item n c t -> IKey c t
+keyof (Item _ (Rule _ (next:_) _) _) = Active next
+keyof (Item _ (Rule _ [] _) _)       = Passive
+
+forward :: Rule n c t -> Rule n c t 
+forward (Rule cat (_:rest) name) = Rule cat rest name
+
+
+instance (Print n, Print c, Print t) => Print (Item n c t) where
+    prt (Item k (Rule cat rhs name) syms) 
+	= "<" ++show k++ ": "++prt name++". "++
+	  prt cat++" -> "++prt rhs++" / "++prt syms++">"
+
+instance (Print c, Print t) => Print (IKey c t) where
+    prt (Active sym) = "?" ++ prt sym
+    prt (Passive) = "!"
+
+