"Committed_by_peb"

src/GF/OldParsing/MCFGrammar.hs

@@ -0,0 +1,206 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : MCFGrammar
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:54 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Definitions of multiple context-free grammars,
+-- parser information and chart conversion
+-----------------------------------------------------------------------------
+
+module GF.OldParsing.MCFGrammar 
+    (-- * Type definitions
+     Grammar,
+     Rule(..),
+     Lin(..),
+     -- * Parser information
+     MCFParser,
+     MEdge,
+     edges2chart,
+     PInfo,
+     pInfo,
+     -- * Ranges
+     Range(..),
+     makeRange,
+     concatRange,
+     unifyRange,
+     unionRange,
+     failRange,
+     -- * Utilities
+     select,
+     updateIndex
+    ) where
+
+-- gf modules:
+import GF.Data.SortedList
+import GF.Data.Assoc
+-- parser modules:
+import GF.OldParsing.Utilities
+import GF.Printing.PrintParser
+
+
+
+select :: [a] -> [(a, [a])]
+select [] = []
+select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ]
+
+updateIndex :: Functor f => Int -> [a] -> (a -> f a) -> f [a]
+updateIndex 0 (a:as) f = fmap (:as) $ f a
+updateIndex n (a:as) f = fmap (a:)  $ updateIndex (n-1) as f
+updateIndex _ _ _ = error "ParserUtils.updateIndex: Index out of range"
+
+
+------------------------------------------------------------
+-- grammar types
+
+type Grammar n c l t = [Rule n c l t]
+data Rule    n c l t = Rule c [c] [Lin c l t] n
+		       deriving (Eq, Ord, Show)
+data Lin       c l t = Lin l [Symbol (c, l, Int) t]
+		       deriving (Eq, Ord, Show)
+
+-- variants is simply several linearizations with the same label
+
+
+------------------------------------------------------------
+-- parser information
+
+type PInfo n c l t = Grammar n c l t
+
+pInfo :: Grammar n c l t -> PInfo n c l t
+pInfo = id
+
+type MCFParser n c l t = PInfo n c l t -> [c] -> Input t -> ParseChart n (MEdge c l)
+
+type MEdge c l = (c, [(l, Range)])
+
+edges2chart :: (Ord n, Ord c, Ord l) =>
+	       [(n, MEdge c l, [MEdge c l])] -> ParseChart n (MEdge c l)
+edges2chart edges = fmap groupPairs $ accumAssoc id $
+		    [ (medge, (name, medges)) | (name, medge, medges) <- edges ]
+
+
+------------------------------------------------------------
+-- ranges as sets of int-pairs
+
+newtype Range = Rng (SList (Int, Int)) deriving (Eq, Ord, Show)
+
+makeRange :: SList (Int, Int) -> Range
+makeRange rho = Rng rho
+
+concatRange :: Range -> Range -> Range
+concatRange (Rng rho) (Rng rho') = Rng $ nubsort [ (i,k) | (i,j) <- rho, (j',k) <- rho', j==j' ]
+
+unifyRange :: Range -> Range -> Range
+unifyRange  (Rng rho) (Rng rho') = Rng $ rho <**> rho'
+
+unionRange :: Range -> Range -> Range
+unionRange  (Rng rho) (Rng rho') = Rng $ rho <++> rho'
+
+failRange :: Range
+failRange = Rng []
+
+
+------------------------------------------------------------
+-- pretty-printing
+
+instance (Print n, Print c, Print l, Print t) => Print (Rule n c l t) where
+    prt (Rule cat args record name) 
+	= prt name ++ ". " ++ prt cat ++ " -> " ++ prtSep " " args ++ "\n" ++ prt record
+    prtList = concatMap prt
+
+instance (Print c, Print l, Print t) => Print (Lin c l t) where
+    prt (Lin lbl lin) = prt lbl ++ " = " ++ prtSep " " (map (symbol prArg (show.prt)) lin)
+	where prArg (cat, lbl, arg) = prt cat ++ "@" ++ prt arg ++ "." ++ prt lbl
+    prtList = prtBeforeAfter "\t" "\n" 
+
+instance Print Range where
+    prt (Rng rho) = "(" ++ prtSep "|" [ show i ++ "-" ++ show j | (i,j) <- rho ] ++ ")"
+
+{-
+------------------------------------------------------------
+-- items & forests
+
+data Item    n c l   = Item n (MEdge c l) [[MEdge c l]]
+		       deriving (Eq, Ord, Show)
+type MEdge     c l   = (c, [Edge l])
+
+items2forests :: (Ord n, Ord c, Ord l) => Edge ((c, l) -> Bool) -> [Item n c l] -> [ParseForest n]
+
+----------
+
+items2forests (Edge i0 k0 startCat) items 
+    = concatMap edge2forests $ filter checkEdge $ aElems chart
+    where edge2forests (cat, []) = [FMeta]
+	  edge2forests edge = filter checkForest $ map item2forest (chart ? edge)
+
+	  item2forest (Item name _ children) = FNode name [ forests | edges <- children,
+							    forests <- mapM edge2forests edges ]
+
+	  checkEdge (cat, [Edge i k lbl]) = i == i0 && k == k0 && startCat (cat, lbl)
+	  checkEdge _ = False
+
+          checkForest (FNode _ children) = not (null children)
+
+          chart = accumAssoc id [ (edge, item) | item@(Item _ edge _) <- items ]
+-}
+
+
+------------------------------------------------------------
+-- grammar checking
+{-
+--checkGrammar :: (Ord c, Ord l, Print n, Print c, Print l, Print t) => Grammar n c l t -> [String]
+
+checkGrammar rules
+    = do rule@(Rule cat rhs record name) <- rules
+	 if null record 
+            then [ "empty linearization record in rule: " ++ prt rule ]
+	    else [ "category does not exist: " ++ prt rcat ++ "\n" ++
+		   "  - in rule: " ++ prt rule |
+		   rcat <- rhs, rcat `notElem` lhsCats ] ++
+ 	         do Lin _ lin <- record  
+		    Cat (arg, albl) <- lin
+		    if arg<0 || arg>=length rhs 
+		       then [ "argument index out of range: " ++ show arg ++ "/" ++ prt albl ++ "\n" ++
+			      "  - in rule: " ++ prt rule ]
+		       else [ "label does not exist: " ++ prt albl ++ "\n" ++
+			      "  - from rule: " ++ prt rule ++
+			      "  - in rule: " ++ prt arule |
+			      arule@(Rule _ acat _ arecord) <- rules,
+			      acat == rhs !! arg,
+			      albl `notElem` [ lbl | Lin lbl _ <- arecord ] ]
+    where lhsCats = nubsort [ cat | Rule _ cat _ _ <- rules ]
+-}
+
+
+
+
+
+{-----
+------------------------------------------------------------
+-- simplifications 
+
+splitMRule :: (Ord n, Ord c, Ord l, Ord t) => Grammar n c l t -> Rule n c l t -> [Rule n c l t]
+splitMRule rules (Rule name cat args record) = nubsort [ (Rule name cat args splitrec) |
+							 (cat', lbls) <- rhsCats, cat == cat',
+							 let splitrec = [ lin | lin@(Lin lbl _) <- record, lbl `elem` lbls ] ]
+    where rhsCats = limit rhsC lhsCats
+	  lhsCats = nubsort [ (cat, [lbl]) | Rule _ cat _ record <- rules, Lin lbl _ <- record ]
+	  rhsC (cat, lbls) = nubsort [ (rcat, rlbls) |
+				       Rule _ cat' rhs lins <- rules, cat == cat',
+				       (arg, rcat) <- zip [0..] rhs,
+				       let rlbls = nubsort [ rlbl | Lin lbl lin <- lins, lbl `elem` lbls,
+							     Cat (arg', rlbl) <- lin, arg == arg' ],
+				       not $ null rlbls
+				     ]
+
+
+----}
+
+
+