"Committed_by_peb"

1 files changed, 71 insertions, 0 deletions

diff --git a/src/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs b/src/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs
new file mode 100644
index 000000000..650f8b646
--- /dev/null
+++ b/src/GF/OldParsing/ConvertGFCtoMCFG/Coercions.hs
@@ -0,0 +1,71 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : ConvertGFCtoMCFG.Coercions
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/11 13:52:55 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Adding coercion functions to a MCFG if necessary.
+-----------------------------------------------------------------------------
+
+
+module GF.OldParsing.ConvertGFCtoMCFG.Coercions (addCoercions) where
+
+import GF.System.Tracing
+import GF.Printing.PrintParser
+import GF.Printing.PrintSimplifiedTerm
+-- import PrintGFC
+-- import qualified PrGrammar as PG
+
+import qualified Ident
+import GF.OldParsing.Utilities
+import GF.OldParsing.GrammarTypes 
+import GF.OldParsing.MCFGrammar (Rule(..), Lin(..))
+import GF.Data.SortedList
+import List (groupBy) -- , transpose)
+
+----------------------------------------------------------------------
+
+addCoercions :: MCFGrammar -> MCFGrammar
+addCoercions rules = coercions ++ rules
+    where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | 
+					Rule head args lins _ <- rules, 
+					let lbls = [ lbl | Lin lbl _ <- lins ] ]
+	  allHeadSet = nubsort allHeads
+	  allArgSet  = union   allArgs <\\> map fst allHeadSet
+	  coercions = tracePrt "#coercions total" (prt . length) $
+		      concat $
+		      tracePrt "#coercions per cat" (prtList . map length) $
+		      combineCoercions 
+		        (groupBy sameCatFst allHeadSet) 
+			(groupBy sameCat    allArgSet)
+	  sameCatFst a b = sameCat (fst a) (fst b)
+
+
+combineCoercions [] _ = []
+combineCoercions _ [] = []
+combineCoercions allHeads'@(heads:allHeads) allArgs'@(args:allArgs) 
+    = case compare (mainCat $ fst $ head heads) (mainCat $ head args) of
+        LT -> combineCoercions allHeads  allArgs'
+	GT -> combineCoercions allHeads' allArgs
+	EQ -> makeCoercion heads args : combineCoercions allHeads allArgs
+
+
+makeCoercion heads args = [ Rule arg [head] lins coercionName |
+			    (head@(MCFCat _ headCns), lbls) <- heads, 
+			    let lins = [ Lin lbl [Cat (head, lbl, 0)] | lbl <- lbls ],
+			    arg@(MCFCat _ argCns) <- args,
+			    argCns `subset` headCns ]
+
+
+coercionName = Ident.IW
+
+mainCat (MCFCat c _) = c
+
+sameCat mc1 mc2 = mainCat mc1 == mainCat mc2
+
+