From aa309abecf2640daf015c5afaffacb3668777b3f Mon Sep 17 00:00:00 2001
From: bringert <bringert@cs.chalmers.se>
Date: Thu, 13 Apr 2006 13:33:35 +0000
Subject: [PATCH] Added top-down filtering to the GSL printer.

---
 src/GF/Speech/PrGSL.hs    |  2 +-
 src/GF/Speech/Relation.hs |  2 +-
 src/GF/Speech/SRG.hs      | 19 +++++++++++++++++--
 3 files changed, 19 insertions(+), 4 deletions(-)

diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs
index b5532f07d..5fdb28e8e 100644
--- a/src/GF/Speech/PrGSL.hs
+++ b/src/GF/Speech/PrGSL.hs
@@ -33,7 +33,7 @@ import Data.Char (toUpper,toLower)
 gslPrinter :: Ident -- ^ Grammar name
 	   -> Options -> Maybe Probs -> CGrammar -> String
 gslPrinter name opts probs cfg = prGSL srg ""
-    where srg = makeSimpleSRG name opts probs $ rmPunctCFG cfg
+    where srg = topDownFilter $ makeSimpleSRG name opts probs $ rmPunctCFG cfg
 
 prGSL :: SRG -> ShowS
 prGSL (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs})
diff --git a/src/GF/Speech/Relation.hs b/src/GF/Speech/Relation.hs
index c66a07d10..61c2469b8 100644
--- a/src/GF/Speech/Relation.hs
+++ b/src/GF/Speech/Relation.hs
@@ -13,7 +13,7 @@
 -----------------------------------------------------------------------------
 
 module GF.Speech.Relation (Rel, mkRel
-                           , isRelatedTo
+                           , allRelated , isRelatedTo
                            , transitiveClosure
                            , reflexiveClosure, reflexiveClosure_
                            , symmetricClosure
diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs
index e81ae4781..0334c1301 100644
--- a/src/GF/Speech/SRG.hs
+++ b/src/GF/Speech/SRG.hs
@@ -20,17 +20,19 @@
 
 module GF.Speech.SRG (SRG(..), SRGRule(..), SRGAlt(..),
                       makeSimpleSRG, makeSRG
-                     , lookupFM_, prtS) where
+                     , lookupFM_, prtS
+                     , topDownFilter) where
 
 import GF.Data.Operations
 import GF.Data.Utilities
 import GF.Infra.Ident
 import GF.Formalism.CFG
 import GF.Formalism.Utilities (Symbol(..), NameProfile(..)
-                              , Profile, SyntaxForest)
+                              , Profile, SyntaxForest, filterCats)
 import GF.Conversion.Types
 import GF.Infra.Print
 import GF.Speech.TransformCFG
+import GF.Speech.Relation
 import GF.Infra.Option
 import GF.Probabilistic.Probabilistic (Probs)
 
@@ -38,6 +40,8 @@ import Data.List
 import Data.Maybe (fromMaybe)
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 data SRG = SRG { grammarName :: String    -- ^ grammar name
 		 , startCat :: String     -- ^ start category name
@@ -127,6 +131,17 @@ mkCatNames :: String   -- ^ Category name prefix
 mkCatNames prefix origNames = Map.fromList (zip origNames names)
     where names = [prefix ++ "_" ++ show x | x <- [0..]]
 
+
+-- | Remove categories which are not reachable from the start category.
+topDownFilter :: SRG -> SRG
+topDownFilter srg@(SRG { startCat = start, rules = rs }) = srg { rules = rs' }
+  where 
+  rs' = [ r | r@(SRGRule c _ _) <- rs, c `Set.member` keep]
+  rhsCats = [ (c,c') | r@(SRGRule c _ ps) <- rs, 
+                       SRGAlt _ _ ss <- ps, 
+                       c' <- filterCats ss]
+  keep = allRelated (transitiveClosure $ mkRel rhsCats) start
+
 --
 -- * Utilities for building and printing SRGs
 --