"Committed_by_peb"

2 files changed, 104 insertions, 2 deletions

diff --git a/src/GF/Conversion/GFC.hs b/src/GF/Conversion/GFC.hs
index 21b52d2b1..765fb10e0 100644
--- a/src/GF/Conversion/GFC.hs
+++ b/src/GF/Conversion/GFC.hs
@@ -4,9 +4,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/14 11:42:05 $ 
+-- > CVS $Date: 2005/04/14 18:38:36 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.3 $
+-- > CVS $Revision: 1.4 $
 --
 -- All conversions from GFC 
 -----------------------------------------------------------------------------
@@ -25,6 +25,9 @@ import qualified GF.Conversion.RemoveSingletons as RemSing
 import qualified GF.Conversion.SimpleToMCFG as S2M
 import qualified GF.Conversion.MCFGtoCFG as M2C
 
+----------------------------------------------------------------------
+-- * single step conversions
+
 gfc2simple :: (CanonGrammar, Ident) -> SGrammar
 gfc2simple = G2S.convertGrammar
 
@@ -43,4 +46,21 @@ simple2mcfg_strict = S2M.convertGrammarStrict
 mcfg2cfg :: MGrammar -> CGrammar
 mcfg2cfg = M2C.convertGrammar
 
+----------------------------------------------------------------------
+-- * GFC -> MCFG
+
+-- | default conversion: 
+--
+--  - instantiating finite dependencies ('removeSingletons . simple2finite')
+--  - nondeterministic MCFG conversion ('simple2mcfg_nondet')
+gfc2mcfg :: (CanonGrammar, Ident) -> MGrammar
+gfc2mcfg = simple2mcfg_nondet . removeSingletons . simple2finite . gfc2simple
+
+----------------------------------------------------------------------
+-- * GFC -> CFG
+
+-- | default conversion = default mcfg conversion + trivial cfg conversion
+gfc2cfg :: (CanonGrammar, Ident) -> CGrammar
+gfc2cfg = mcfg2cfg . gfc2mcfg
+
 
diff --git a/src/GF/Conversion/RemoveSingletons.hs b/src/GF/Conversion/RemoveSingletons.hs
new file mode 100644
index 000000000..9c5ff274e
--- /dev/null
+++ b/src/GF/Conversion/RemoveSingletons.hs
@@ -0,0 +1,82 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/14 18:41:21 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Instantiating all types which only have one single element.
+--
+-- Should be merged into 'GF.Conversion.FiniteToSimple'
+-----------------------------------------------------------------------------
+
+module GF.Conversion.RemoveSingletons where
+
+import GF.System.Tracing
+import GF.Infra.Print
+
+import GF.Formalism.Utilities
+import GF.Formalism.GCFG
+import GF.Formalism.SimpleGFC
+import GF.Conversion.Types
+
+import GF.Data.SortedList
+import GF.Data.Assoc
+
+import List (mapAccumL)
+
+convertGrammar :: SGrammar -> SGrammar
+convertGrammar grammar = if singles == emptyAssoc then grammar
+			 else tracePrt "#singleton-removed rules" (prt . length) $
+			      map (convertRule singles) grammar
+    where singles = calcSingletons grammar
+
+convertRule :: Assoc SCat (SyntaxForest Fun, Maybe STerm) -> SRule -> SRule
+convertRule singles rule@(Rule (Abs _ decls _) _)
+    = if all (Nothing ==) singleArgs then rule
+      else instantiateSingles singleArgs rule
+    where singleArgs = map (lookupAssoc singles . decl2cat) decls
+
+instantiateSingles :: [Maybe (SyntaxForest Fun, Maybe STerm)] -> SRule -> SRule
+instantiateSingles singleArgs (Rule (Abs decl decls (Name fun profile)) (Cnc lcat lcats lterm))
+    = Rule (Abs decl decls' (Name fun profile')) (Cnc lcat lcats' lterm')
+    where (decls', lcats') = unzip [ (d, l) | (Nothing, d, l) <- zip3 singleArgs decls lcats ]
+	  profile'  = map (fmap fst) exProfile `composeProfiles` profile
+	  newArgs   = map (fmap snd) exProfile
+	  lterm'    = fmap (instantiateLin newArgs) lterm
+	  exProfile = snd $ mapAccumL mkProfile 0 singleArgs
+	  mkProfile nr (Just trm) = (nr, Constant trm)
+	  mkProfile nr (Nothing)  = (nr+1, Unify [nr])
+
+instantiateLin :: [Profile (Maybe STerm)] -> STerm -> STerm
+instantiateLin newArgs = inst
+    where inst (Arg nr cat path) 
+	      = case newArgs !! nr of
+		  Unify [nr']          -> Arg nr' cat path
+		  Constant (Just term) -> termFollowPath path term
+		  Constant Nothing     -> error "instantiateLin: argument has no linearization"
+	  inst (cn :^ terms) = cn :^ map inst terms
+	  inst (Rec rec)     = Rec [ (lbl, inst term) | (lbl, term) <- rec ]
+	  inst (term :. lbl) = inst term +. lbl
+	  inst (Tbl tbl)     = Tbl [ (pat, inst term) | (pat, term) <- tbl ]
+	  inst (term :! sel) = inst term +! inst sel
+	  inst (Variants ts) = variants (map inst ts)
+	  inst (t1 :++ t2)   = inst t1 ?++ inst t2
+	  inst term          = term
+
+----------------------------------------------------------------------
+
+calcSingletons :: SGrammar -> Assoc SCat (SyntaxForest Fun, Maybe STerm)
+calcSingletons rules = listAssoc singleCats
+    where singleCats = tracePrt "singleton cats" (prtSep " ") $
+		       [ (cat, (constantNameToForest name, lin)) | 
+			 (cat, [([], name, lin)]) <- rulesByCat ]
+	  rulesByCat = groupPairs $ nubsort
+		       [ (decl2cat cat, (args, name, lin)) | 
+			 Rule (Abs cat args name) (Cnc _ _ lin) <- rules ]
+
+
+