GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

1 files changed, 206 insertions, 0 deletions

diff --git a/src-3.0/GF/Parsing/MCFG/Range.hs b/src-3.0/GF/Parsing/MCFG/Range.hs
new file mode 100644
index 000000000..91671fa00
--- /dev/null
+++ b/src-3.0/GF/Parsing/MCFG/Range.hs
@@ -0,0 +1,206 @@
+---------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/08/08 09:01:25 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.5 $
+--
+-- Definitions of ranges, and operations on ranges
+-----------------------------------------------------------------------------
+
+module GF.Parsing.MCFG.Range
+    ( Range(..), makeRange, concatRange, rangeEdge, edgeRange, minRange, maxRange,
+      LinRec, RangeRec,
+      makeRangeRec, rangeRestRec, rangeRestrictRule, 
+      projection, unifyRec, substArgRec
+    ) where
+
+
+-- Haskell
+import Data.List
+import Control.Monad
+
+-- GF modules
+import GF.Formalism.GCFG
+import GF.Formalism.MCFG
+import GF.Formalism.Utilities
+import GF.Infra.Print
+import GF.Data.Assoc ((?))
+import GF.Data.Utilities (updateNthM)
+
+------------------------------------------------------------
+-- ranges as single pairs
+
+data Range = Range (Int, Int)
+	   | EmptyRange
+             deriving (Eq, Ord, Show)
+
+makeRange   :: (Int, Int) -> Range
+concatRange :: Range -> Range -> [Range]
+rangeEdge   :: a -> Range -> Edge a
+edgeRange   :: Edge a -> Range
+minRange    :: Range -> Int
+maxRange    :: Range -> Int
+
+makeRange                              = Range 
+concatRange EmptyRange rng = return rng
+concatRange rng EmptyRange = return rng
+concatRange (Range(i,j)) (Range(j',k)) = [ Range(i,k) | j==j']
+rangeEdge    a           (Range(i,j))  = Edge i j a
+edgeRange   (Edge i j _)               = Range (i,j)
+minRange    (Range rho)                = fst rho
+maxRange    (Range rho)                = snd rho
+
+instance Print Range where
+    prt (Range (i,j)) = "(" ++ show i ++ "-" ++ show j ++ ")"
+    prt (EmptyRange)  = "(?)"
+
+{-- Types --------------------------------------------------------------------
+  Linearization- and Range records implemented as lists
+-----------------------------------------------------------------------------}
+
+type LinRec c l t = [Lin c l t]
+ 
+type RangeRec   l = [(l, Range)]
+
+
+{-- Functions ----------------------------------------------------------------
+  Concatenation         : Concatenation of Ranges, Symbols and Linearizations 
+                          and records of Linearizations 
+  Record transformation : Makes a Range record from a fully instantiated
+                          Linearization record 
+  Record projection     : Given a label, returns the corresponding Range
+  Range restriction     : Range restriction of Tokens, Symbols, 
+                          Linearizations and Records given a list of Tokens
+  Record replacment     : Substitute a record for another in a list of Range 
+                          records
+  Argument substitution : Substitution of a Cat c to a Tok Range, where 
+                          Range is the cover of c
+			  Note: The argument is still a Symbol c Range
+  Subsumation           : Checks if a Range record subsumes another Range 
+                          record
+  Record unification    : Unification of two Range records
+-----------------------------------------------------------------------------}
+
+
+--- Concatenation ------------------------------------------------------------
+
+
+concSymbols :: [Symbol c Range] -> [[Symbol c Range]]
+concSymbols (Tok rng:Tok rng':toks) = do rng'' <- concatRange rng rng'
+					 concSymbols (Tok rng'':toks)
+concSymbols (sym:syms)              = do syms' <- concSymbols syms
+					 return (sym:syms')
+concSymbols []                      = return []
+
+
+concLin :: Lin c l Range -> [Lin c l Range]
+concLin (Lin lbl syms) = do syms' <- concSymbols syms
+			    return (Lin lbl syms')
+
+
+concLinRec :: LinRec c l Range -> [LinRec c l Range]
+concLinRec = mapM concLin 
+
+
+--- Record transformation ----------------------------------------------------
+
+makeRangeRec :: LinRec c l Range -> RangeRec l
+makeRangeRec lins = map convLin lins
+    where convLin (Lin lbl [Tok rng]) = (lbl, rng)
+	  convLin (Lin lbl []) = (lbl, EmptyRange)
+	  convLin _ = error "makeRangeRec"
+
+
+--- Record projection --------------------------------------------------------
+
+projection :: Ord l => l -> RangeRec l -> [Range]
+projection l rec = maybe (fail "projection") return $ lookup l rec
+
+
+--- Range restriction --------------------------------------------------------
+
+rangeRestTok :: Ord t => Input t -> t -> [Range]
+rangeRestTok toks tok = do rng <- inputToken toks ? tok
+			   return (makeRange rng)
+
+
+rangeRestSym :: Ord t => Input t -> Symbol a t -> [Symbol a Range]
+rangeRestSym toks (Tok tok) = do rng <- rangeRestTok toks tok
+				 return (Tok rng)
+rangeRestSym _ (Cat c)      = return (Cat c)
+
+
+rangeRestLin :: Ord t => Input t -> Lin c l t -> [Lin c l Range]
+rangeRestLin toks (Lin lbl syms) = do syms' <- mapM (rangeRestSym toks) syms
+				      concLin (Lin lbl syms')
+				      -- return (Lin lbl syms')
+
+
+rangeRestRec :: Ord t => Input t -> LinRec c l t -> [LinRec c l Range]
+rangeRestRec toks = mapM (rangeRestLin toks) 
+
+
+rangeRestrictRule :: Ord t => Input t -> MCFRule c n l t -> [MCFRule c n l Range]
+rangeRestrictRule toks (Rule abs (Cnc l ls lins)) = liftM (Rule abs . Cnc l ls) $
+						    rangeRestRec toks lins
+
+--- Argument substitution ----------------------------------------------------
+
+substArgSymbol :: Ord l => Int -> RangeRec l -> Symbol (c, l, Int) Range 
+	       -> Symbol (c, l, Int) Range
+substArgSymbol i rec tok@(Tok rng) = tok
+substArgSymbol i rec cat@(Cat (c, l, j))
+    | i==j      = maybe err Tok $ lookup l rec 
+    | otherwise = cat
+    where err = error "substArg: Label not in range-record"
+
+substArgLin :: Ord l => Int -> RangeRec l -> Lin c l Range 
+	    -> [Lin c l Range]
+substArgLin i rec (Lin lbl syms) = 
+    concLin (Lin lbl (map (substArgSymbol i rec) syms))
+
+
+substArgRec :: Ord l => Int -> RangeRec l -> LinRec c l Range 
+	    -> [LinRec c l Range]
+substArgRec i rec lins = mapM (substArgLin i rec) lins
+
+
+-- Record unification & replacment ---------------------------------------------------------
+
+unifyRec :: Ord l => [RangeRec l] -> Int -> RangeRec l -> [[RangeRec l]]
+unifyRec recs i rec = updateNthM update i recs
+    where update rec' = guard (subsumes rec' rec) >> return rec
+
+-- unifyRec recs i rec = do guard $ subsumes (recs !! i) rec
+-- 			 return $ replaceRec recs i rec
+
+replaceRec :: [RangeRec l] -> Int -> RangeRec l -> [RangeRec l]
+replaceRec recs i rec = before ++ (rec : after)
+    where (before, _ : after) = splitAt i recs
+
+subsumes :: Ord l => RangeRec l -> RangeRec l -> Bool
+subsumes rec rec' = and [r `elem` rec' | r <- rec]
+-- subsumes rec rec' = all (`elem` rec') rec
+
+
+{-
+--- Record unification -------------------------------------------------------
+unifyRangeRecs :: Ord l => [RangeRec l] -> [RangeRec l] -> [[RangeRec l]]
+unifyRangeRecs recs recs' = zipWithM unify recs recs'
+    where unify :: Ord l => RangeRec l -> RangeRec l -> [RangeRec l]
+	  unify rec [] = return rec
+	  unify [] rec = return rec
+	  unify rec1'@(p1@(l1, r1):rec1) rec2'@(p2@(l2, r2):rec2) 
+	      = case compare l1 l2 of
+		LT -> do rec3 <- unify rec1 rec2'
+			 return (p1:rec3)
+		GT -> do rec3 <- unify rec1' rec2
+			 return (p2:rec3)
+		EQ -> do guard (r1 == r2)
+			 rec3 <- unify rec1 rec2
+			 return (p1:rec3)
+-}