From 1738be3a756289fc27d50d9f2ac7259f1db79bae Mon Sep 17 00:00:00 2001
From: bringert <bringert@cs.chalmers.se>
Date: Fri, 3 Mar 2006 10:40:53 +0000
Subject: [PATCH] SRGS generation: use XML module escape mechanism. Added
 beginnings of a not yet working SRGS minimization function.

---
 src/GF/Speech/PrSRGS.hs | 66 +++++++++++++++++++++++++++++++++++++++--
 1 file changed, 63 insertions(+), 3 deletions(-)

diff --git a/src/GF/Speech/PrSRGS.hs b/src/GF/Speech/PrSRGS.hs
index dda0f4d8a..8e358e51f 100644
--- a/src/GF/Speech/PrSRGS.hs
+++ b/src/GF/Speech/PrSRGS.hs
@@ -32,6 +32,8 @@ import GF.Probabilistic.Probabilistic (Probs)
 
 import Data.Char (toUpper,toLower)
 import Data.List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 srgsXmlPrinter :: Ident -- ^ Grammar name
 	       -> Options 
@@ -130,17 +132,17 @@ inProfile x (Unify xs) = x `elem` xs
 inProfile _ (Constant _) = False
 
 prCat :: String -> String
-prCat c = c -- FIXME: escape something?
+prCat c = c
 
 showToken :: Token -> String
-showToken t = t -- FIXME: escape something?
+showToken t = t
 
 oneOf :: [XML] -> XML
 oneOf [x] = x
 oneOf xs = Tag "one-of" [] xs
 
 grammar :: String  -- ^ root
-        -> String -- ^languageq
+        -> String -- ^language
 	-> [XML] -> XML
 grammar root l = Tag "grammar" [("xml:lang", l),
                                 ("xmlns","http://www.w3.org/2001/06/grammar"),
@@ -150,3 +152,61 @@ grammar root l = Tag "grammar" [("xml:lang", l),
 
 meta :: String -> String -> XML
 meta n c = Tag "meta" [("name",n),("content",c)] []
+
+{-
+
+--
+-- * SRGS minimization
+--
+
+minimizeRule :: XML -> XML
+minimizeRule (Tag "rule" attrs cs) 
+    = Tag "rule" attrs (map minimizeOneOf cs)
+      
+minimizeOneOf :: XML -> XML
+minimizeOneOf (Tag "one-of" attrs cs) 
+    = Tag "item" [] (p++[Tag "one-of" attrs cs'])
+  where
+  (pref,cs') = factor cs
+  p = if null pref then [] else [Tag "one-of" [] pref]
+minimizeOneOf x = x
+
+factor :: [XML] -> ([XML],[XML])
+factor xs = case f of
+                    Just (ps,xs') -> (map it ps, map it xs')
+                    Nothing -> ([],xs)
+  where 
+  -- FIXME: maybe getting all the longest terminal prefixes
+  -- is not optimal?
+  f = cartesianFactor $ map (terminalPrefix . unIt) xs
+  unIt (Tag "item" [] cs) = cs
+  it cs = Tag "item" [] cs
+
+terminalPrefix :: [XML] -> ([XML],[XML])
+terminalPrefix cs = (terms, tags ++ cs'')
+  where (tags,cs') = span isTag cs
+        (terms,cs'') = span isTerminalItem cs'
+
+isTag :: XML -> Bool
+isTag (Tag t _ _) = t == "tag"
+isTag _ = False
+
+isTerminalItem :: XML -> Bool
+isTerminalItem (Tag "item" [] [Data _]) = True
+isTerminalItem _ = False
+
+-- 
+-- * Utilities
+--
+
+allEqual :: Eq a => [a] -> Bool
+allEqual [] = True
+allEqual (x:xs) = all (x==) xs
+
+cartesianFactor :: (Ord a, Ord b) => [(a,b)] -> Maybe ([a],[b])
+cartesianFactor xs 
+    | not (null es) && allEqual es = Just (Map.keys m, Set.elems (head es))
+    | otherwise = Nothing
+  where m = Map.fromListWith Set.union [(x,Set.singleton y) | (x,y) <- xs]
+        es = Map.elems m
+-}
\ No newline at end of file