Moved Graph and Relation stuff to separate modules. Added some QuickCheck properties for Relation. Improved relation datastructure and algorithms, making FA generation much faster.

6 files changed, 263 insertions, 105 deletions

diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs
index 73765aed0..590fd1c6d 100644
--- a/src/GF/Speech/CFGToFiniteState.hs
+++ b/src/GF/Speech/CFGToFiniteState.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/14 16:08:35 $ 
+-- > CVS $Date: 2005/10/26 17:13:13 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.4 $
+-- > CVS $Revision: 1.5 $
 --
 -- Approximates CFGs with finite state networks.
 -----------------------------------------------------------------------------
@@ -24,6 +24,7 @@ import GF.Infra.Ident (Ident)
 import GF.Infra.Option (Options)
 
 import GF.Speech.FiniteState
+import GF.Speech.Relation
 import GF.Speech.TransformCFG
 
 cfgToFA :: Ident -- ^ Grammar name
@@ -59,10 +60,10 @@ makeRegular g = groupProds $ concatMap trSet (mutRecCats True g)
 mutRecCats :: Bool    -- ^ If true, all categories will be in some set.
                       --   If false, only recursive categories will be included.
 	   -> CFRules -> [[Cat_]]
-mutRecCats incAll g = equivalenceClasses $ symmetricSubrelation $ transitiveClosure r'
-  where r = nub [(c,c') | (_,rs) <- g, CFRule c ss _ <- rs, Cat c' <- ss]
+mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r
+  where r = mkRel [(c,c') | (_,rs) <- g, CFRule c ss _ <- rs, Cat c' <- ss]
 	allCats = map fst g
-	r' = (if incAll then reflexiveClosure allCats else id) r
+	refl = if incAll then reflexiveClosure_ allCats else reflexiveSubrelation
 
 -- Convert a strongly regular grammar to a finite automaton.
 compileAutomaton :: Cat_ -- ^ Start category
@@ -130,34 +131,3 @@ isLeftLinear ::  Eq c => [c]  -- ^ The categories to consider
 	      -> CFRule c n t -- ^ The rule to check for right-linearity
 	      -> Bool
 isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs
-
-
---
--- * Relations
---
-
--- FIXME: these could use a more efficent data structures and algorithms.
-
-type Rel a = [(a,a)]
-
-isRelatedTo :: Eq a => Rel a -> a  -> a -> Bool
-isRelatedTo r x y = (x,y) `elem` r
-
-transitiveClosure :: Eq a => Rel a -> Rel a
-transitiveClosure r = fix (\r -> r `union` [ (x,w) | (x,y) <- r, (z,w) <- r, y == z ]) r
-
-reflexiveClosure :: Eq a => [a] -- ^ The set over which the relation is defined.
-		 -> Rel a -> Rel a
-reflexiveClosure u r = [(x,x) | x <- u] `union` r
-
-symmetricSubrelation :: Eq a => Rel a -> Rel a
-symmetricSubrelation r = [p | p@(x,y) <- r, (y,x) `elem` r]
-
--- | Get the equivalence classes from an equivalence relation. Since
---   the relation is relexive, the set can be recoved from the relation.
-equivalenceClasses :: Eq a => Rel a -> [[a]]
-equivalenceClasses r = equivalenceClasses_ (nub (map fst r)) r
- where equivalenceClasses_ [] _ = []
-       equivalenceClasses_ (x:xs) r = (x:ys):equivalenceClasses_ zs r
-	   where (ys,zs) = partition (isRelatedTo r x) xs
-
diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index e8e80e4be..42aa99e8b 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/src/GF/Speech/FiniteState.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/22 17:08:48 $ 
+-- > CVS $Date: 2005/10/26 17:13:13 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.13 $
+-- > CVS $Revision: 1.14 $
 --
 -- A simple finite state network module.
 -----------------------------------------------------------------------------
@@ -25,6 +25,7 @@ import Data.List
 import Data.Maybe (catMaybes,fromJust)
 
 import GF.Data.Utilities
+import GF.Speech.Graph
 import qualified GF.Visualization.Graphviz as Dot
 
 type State = Int
@@ -171,68 +172,3 @@ toGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed [] (map mkNode ns)
 			   ++ if n `elem` f then [("style","bold")] else []
 	 mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)]
 
---
--- * Graphs 
---
-
-data Graph n a b = Graph [n] [Node n a] [Edge n b]
-		 deriving (Eq,Show)
-
-type Node n a = (n,a)
-type Edge n b = (n,n,b)
-
-type Incoming n a b = [(Node n a,[Edge n b])]
-type Outgoing n a b = [(Node n a,[Edge n b])]
-
-newGraph :: [n] -> Graph n a b
-newGraph ns = Graph ns [] []
-
-nodes :: Graph n a b -> [Node n a]
-nodes (Graph _ ns _) = ns
-
-edges :: Graph n a b -> [Edge n b]
-edges (Graph _ _ es) = es
-
-nmap :: (a -> c) -> Graph n a b -> Graph n c b
-nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
-
-emap :: (b -> c) -> Graph n a b -> Graph n a c
-emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
-
-newNode :: a -> Graph n a b -> (Graph n a b,n)
-newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
-
-newEdge :: Edge n b -> Graph n a b -> Graph n a b
-newEdge e (Graph c ns es) = Graph c ns (e:es)
-
-newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
-newEdges es' (Graph c ns es) = Graph c ns (es'++es)
-
--- | Get a list of all nodes and their incoming edges.
-incoming :: Ord n => Graph n a b -> Incoming n a b
-incoming = groupEdgesBy getTo
-
--- | Get a list of all nodes and their outgoing edges.
-outgoing :: Ord n => Graph n a b -> Outgoing n a b
-outgoing = groupEdgesBy getFrom
-
-getOutgoing :: Eq n => Outgoing n a b -> n -> [Edge n b]
-getOutgoing out x = head [ es | ((y,_),es) <- out, x == y ]
-
-groupEdgesBy :: (Ord n) => (Edge n b -> n) -> Graph n a b -> [(Node n a,[Edge n b])]
-groupEdgesBy h (Graph _ ns es) = 
-    snd $ mapAccumL f (sortBy (compareBy h) es) (sortBy (compareBy fst) ns)
-  where f es' v@(n,_) = let (nes,es'') = span ((==n) . h) es' in (es'',(v,nes))
-
-getFrom :: Edge n b -> n
-getFrom (f,_,_) = f
-
-getTo :: Edge n b -> n
-getTo (_,t,_) = t
-
-getLabel :: Edge n b -> b
-getLabel (_,_,l) = l
-
-reverseGraph :: Graph n a b -> Graph n a b
-reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
-
diff --git a/src/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs
new file mode 100644
index 000000000..64b73a70a
--- /dev/null
+++ b/src/GF/Speech/Graph.hs
@@ -0,0 +1,88 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Graph
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/26 17:13:13 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- A simple graph module.
+-----------------------------------------------------------------------------
+module GF.Speech.Graph ( Graph(..), Node, Edge, Incoming, Outgoing
+                        , newGraph, nodes, edges
+                        , nmap, emap, newNode, newEdge, newEdges
+                        , incoming, outgoing, getOutgoing
+                        , getFrom, getTo, getLabel
+                        , reverseGraph                             
+                       ) where
+
+import GF.Data.Utilities
+
+import Data.List
+
+data Graph n a b = Graph [n] [Node n a] [Edge n b]
+		 deriving (Eq,Show)
+
+type Node n a = (n,a)
+type Edge n b = (n,n,b)
+
+type Incoming n a b = [(Node n a,[Edge n b])]
+type Outgoing n a b = [(Node n a,[Edge n b])]
+
+newGraph :: [n] -> Graph n a b
+newGraph ns = Graph ns [] []
+
+nodes :: Graph n a b -> [Node n a]
+nodes (Graph _ ns _) = ns
+
+edges :: Graph n a b -> [Edge n b]
+edges (Graph _ _ es) = es
+
+nmap :: (a -> c) -> Graph n a b -> Graph n c b
+nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
+
+emap :: (b -> c) -> Graph n a b -> Graph n a c
+emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
+
+newNode :: a -> Graph n a b -> (Graph n a b,n)
+newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
+
+newEdge :: Edge n b -> Graph n a b -> Graph n a b
+newEdge e (Graph c ns es) = Graph c ns (e:es)
+
+newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
+newEdges es' (Graph c ns es) = Graph c ns (es'++es)
+
+-- | Get a list of all nodes and their incoming edges.
+incoming :: Ord n => Graph n a b -> Incoming n a b
+incoming = groupEdgesBy getTo
+
+-- | Get a list of all nodes and their outgoing edges.
+outgoing :: Ord n => Graph n a b -> Outgoing n a b
+outgoing = groupEdgesBy getFrom
+
+-- | From a list of outgoing edges, get all edges
+--   starting at a given node.
+getOutgoing :: Eq n => Outgoing n a b -> n -> [Edge n b]
+getOutgoing out x = head [ es | ((y,_),es) <- out, x == y ]
+
+groupEdgesBy :: (Ord n) => (Edge n b -> n) -> Graph n a b -> [(Node n a,[Edge n b])]
+groupEdgesBy h (Graph _ ns es) = 
+    snd $ mapAccumL f (sortBy (compareBy h) es) (sortBy (compareBy fst) ns)
+  where f es' v@(n,_) = let (nes,es'') = span ((==n) . h) es' in (es'',(v,nes))
+
+getFrom :: Edge n b -> n
+getFrom (f,_,_) = f
+
+getTo :: Edge n b -> n
+getTo (_,t,_) = t
+
+getLabel :: Edge n b -> b
+getLabel (_,_,l) = l
+
+reverseGraph :: Graph n a b -> Graph n a b
+reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
+
diff --git a/src/GF/Speech/Relation.hs b/src/GF/Speech/Relation.hs
new file mode 100644
index 000000000..2ad3faccb
--- /dev/null
+++ b/src/GF/Speech/Relation.hs
@@ -0,0 +1,124 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Relation
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/26 17:13:13 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- A simple module for relations.
+-----------------------------------------------------------------------------
+
+module GF.Speech.Relation (Rel, mkRel
+                           , isRelatedTo
+                           , transitiveClosure
+                           , reflexiveClosure, reflexiveClosure_
+                           , symmetricClosure
+                           , symmetricSubrelation, reflexiveSubrelation
+                           , equivalenceClasses
+                           , isTransitive, isReflexive, isSymmetric
+                           , isEquivalence,
+                           , isSubRelationOf) where
+
+import Data.List
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import GF.Data.Utilities
+
+type Rel a = Map a (Set a)
+
+-- | Creates a relation from a list of related pairs.
+mkRel :: Ord a => [(a,a)] -> Rel a
+mkRel ps = relates ps Map.empty
+
+relToList :: Rel a -> [(a,a)]
+relToList r = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys ]
+
+-- | Add a pair to the relation.
+relate :: Ord a => a -> a -> Rel a -> Rel a
+relate x y r = Map.insertWith Set.union x (Set.singleton y) r
+
+-- | Add a list of pairs to the relation.
+relates :: Ord a => [(a,a)] -> Rel a -> Rel a
+relates ps r = foldl (\r' (x,y) -> relate x y r') r ps
+
+-- | Checks if an element is related to another.
+isRelatedTo :: Ord a => Rel a -> a  -> a -> Bool
+isRelatedTo r x y = maybe False (y `Set.member`) (Map.lookup x r)
+
+-- | Get the set of elements to which a given element is related.
+allRelated :: Ord a => Rel a -> a -> Set a
+allRelated r x = fromMaybe Set.empty (Map.lookup x r)
+
+-- | Get all elements in the relation.
+domain :: Ord a => Rel a -> Set a
+domain r = foldl Set.union (Map.keysSet r) (Map.elems r)
+
+-- | Keep only pairs for which both elements are in the given set.
+intersectSetRel :: Ord a => Set a -> Rel a -> Rel a
+intersectSetRel s = filterRel (\x y -> x `Set.member` s && y `Set.member` s)
+
+transitiveClosure :: Ord a => Rel a -> Rel a
+transitiveClosure r = fix (Map.map growSet) r
+  where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
+
+reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
+		 -> Rel a -> Rel a
+reflexiveClosure_ u r = relates [(x,x) | x <- u] r
+
+-- | Uses 'domain'
+reflexiveClosure :: Ord a => Rel a -> Rel a
+reflexiveClosure r = reflexiveClosure_ (Set.toList $ domain r) r
+
+symmetricClosure :: Ord a => Rel a -> Rel a
+symmetricClosure r = relates [ (y,x) | (x,y) <- relToList r ] r
+
+symmetricSubrelation :: Ord a => Rel a -> Rel a
+symmetricSubrelation r = filterRel (flip $ isRelatedTo r) r
+
+reflexiveSubrelation :: Ord a => Rel a -> Rel a
+reflexiveSubrelation r = intersectSetRel (reflexiveElements r) r
+
+-- | Get the set of elements which are related to themselves.
+reflexiveElements :: Ord a => Rel a -> Set a
+reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
+
+-- | Keep the related pairs for which the predicate is true.
+filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a 
+filterRel p = purgeEmpty . Map.mapWithKey (Set.filter . p)
+
+-- | Remove keys that map to no elements.
+purgeEmpty :: Ord a => Rel a -> Rel a
+purgeEmpty r = Map.filter (not . Set.null) r
+
+
+-- | Get the equivalence classes from an equivalence relation. 
+equivalenceClasses :: Ord a => Rel a -> [[a]]
+equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
+ where equivalenceClasses_ [] _ = []
+       equivalenceClasses_ (x:xs) r = Set.toList ys:equivalenceClasses_ zs r
+	   where ys = allRelated r x
+                 zs = [x' | x' <- xs, not (x' `Set.member` ys)]
+
+isTransitive :: Ord a => Rel a -> Bool
+isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, 
+                      y <- Set.toList ys, z <- Set.toList (allRelated r y)]
+
+isReflexive :: Ord a => Rel a -> Bool
+isReflexive r = all (\ (x,ys) -> x `Set.member` ys) (Map.toList r)
+
+isSymmetric :: Ord a => Rel a -> Bool
+isSymmetric r = and [isRelatedTo r y x | (x,y) <- relToList r]
+
+isEquivalence :: Ord a => Rel a -> Bool
+isEquivalence r = isReflexive r && isSymmetric r && isTransitive r
+
+isSubRelationOf :: Ord a => Rel a -> Rel a -> Bool
+isSubRelationOf r1 r2 = all (uncurry (isRelatedTo r2)) (relToList r1)
\ No newline at end of file
diff --git a/src/GF/Speech/RelationQC.hs b/src/GF/Speech/RelationQC.hs
new file mode 100644
index 000000000..157a53462
--- /dev/null
+++ b/src/GF/Speech/RelationQC.hs
@@ -0,0 +1,39 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : RelationQC
+-- Maintainer  : BB
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/26 17:13:13 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.1 $
+--
+-- QuickCheck properties for GF.Speech.Relation
+-----------------------------------------------------------------------------
+
+module GF.Speech.RelationQC where
+
+import GF.Speech.Relation
+
+import Test.QuickCheck
+
+prop_transitiveClosure_trans :: [(Int,Int)] -> Bool
+prop_transitiveClosure_trans ps = isTransitive (transitiveClosure (mkRel ps))
+
+prop_symmetricSubrelation_symm :: [(Int,Int)] -> Bool
+prop_symmetricSubrelation_symm ps = isSymmetric (symmetricSubrelation (mkRel ps))
+
+prop_symmetricSubrelation_sub :: [(Int,Int)] -> Bool
+prop_symmetricSubrelation_sub ps = symmetricSubrelation r `isSubRelationOf` r
+  where r = mkRel ps
+
+prop_symmetricClosure_symm :: [(Int,Int)] -> Bool
+prop_symmetricClosure_symm ps = isSymmetric (symmetricClosure (mkRel ps))
+
+prop_reflexiveClosure_refl :: [(Int,Int)] -> Bool
+prop_reflexiveClosure_refl ps = isReflexive (reflexiveClosure (mkRel ps))
+
+prop_mkEquiv_equiv :: [(Int,Int)] -> Bool
+prop_mkEquiv_equiv ps = isEquivalence (mkEquiv ps)
+  where mkEquiv = transitiveClosure . symmetricClosure . reflexiveClosure . mkRel
\ No newline at end of file
diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs
index 24f2e868d..e9fb000be 100644
--- a/src/GF/Speech/SRG.hs
+++ b/src/GF/Speech/SRG.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/09/14 15:17:30 $ 
+-- > CVS $Date: 2005/10/26 17:13:13 $ 
 -- > CVS $Author: bringert $
--- > CVS $Revision: 1.17 $
+-- > CVS $Revision: 1.18 $
 --
 -- Representation of, conversion to, and utilities for 
 -- printing of a general Speech Recognition Grammar. 
@@ -33,6 +33,7 @@ import Data.List
 import Data.Maybe (fromMaybe)
 import Data.FiniteMap
 
+import Debug.Trace
 
 data SRG = SRG { grammarName :: String    -- ^ grammar name
 		 , startCat :: String     -- ^ start category name