Refactored Graph module. Remove some unneccessary states in slf networks.

3 files changed, 117 insertions, 51 deletions

diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index 8dab428bc..ab2aed838 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/src/GF/Speech/FiniteState.hs
@@ -20,7 +20,8 @@ module GF.Speech.FiniteState (FA, State, NFA, DFA,
                               newTransition,
 			      mapStates, mapTransitions,
                               oneFinalState,
-			      moveLabelsToNodes, minimize,
+			      moveLabelsToNodes, removeTrivialEmptyNodes,
+                              minimize,
                               dfa2nfa,
                               unusedNames, renameStates,
 			      prFAGraphviz, faToGraphviz) where
@@ -119,26 +120,56 @@ oneFinalState nl el fa =
 --   to one where the labels are on the nodes instead. This can add
 --   up to one extra node per edge.
 moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
-moveLabelsToNodes = removeTrivialEmptyNodes . onGraph f
-  where f gr@(Graph c _ _) = Graph c' ns (concat ess)
-	    where is = incomingToList $ incoming gr
+moveLabelsToNodes = onGraph f
+  where f g@(Graph c _ _) = Graph c' ns (concat ess)
+	    where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)]
 		  (c',is') = mapAccumL fixIncoming c is
 		  (ns,ess) = unzip (concat is')
 
--- | Remove nodes which are not start or final, and have
---   exactly one incoming or exactly one outgoing edge.
-removeTrivialEmptyNodes :: FA n (Maybe a) () -> FA n (Maybe a) ()
-removeTrivialEmptyNodes = id -- FIXME: implement
 
-fixIncoming :: (Ord n, Eq a) => [n] -> (Node n (),[Edge n (Maybe a)]) -> ([n],[(Node n (Maybe a),[Edge n ()])])
+-- | Remove empty nodes which are not start or final, and have
+--   exactly one outgoing edge.
+removeTrivialEmptyNodes :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
+removeTrivialEmptyNodes = pruneUnreachable . skipEmptyNodes
+
+-- | Move edges to empty nodes with one outgoing edge to the next edge.
+skipEmptyNodes :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
+skipEmptyNodes = onGraph og
+  where 
+  og g@(Graph c ns es) = Graph c ns (map changeEdge es)
+    where
+    info = nodeInfo g
+    changeEdge e@(f,t,()) 
+      | isNothing (getNodeLabel info t) 
+          = case getOutgoing info t of
+                [(_,t',())] -> (f,t',())
+                _ -> e
+      | otherwise = e
+
+isInternal :: Eq n => FA n a b -> n -> Bool
+isInternal (FA _ start final) n = n /= start && n `notElem` final
+
+-- | Remove all internal nodes with no incoming edges.
+pruneUnreachable :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
+pruneUnreachable fa = onGraph f fa
+ where
+ f g = removeNodes (Set.fromList [ n | (n,_) <- nodes g, 
+                                   isInternal fa n,
+                                   null (getIncoming info n)]) g
+  where info = nodeInfo g
+
+fixIncoming :: (Ord n, Eq a) => [n] 
+            -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges
+            -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their
+                                                      -- incoming edges.
 fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
-  where ls = nub $ map getLabel es
+  where ls = nub $ map edgeLabel es
 	(cs',cs'') = splitAt (length ls) cs
 	newNodes = zip cs' ls
 	es' = [ (x,n,()) | x <- map fst newNodes ]
 	-- separate cyclic and non-cyclic edges
 	(cyc,ncyc) = partition (\ (f,_,_) -> f == n) es
-	       -- keep all incoming non-cyclic edges with the right label
+	          -- keep all incoming non-cyclic edges with the right label
 	to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l']
 	          -- for each cyclic edge with the right label, 
 	          -- add an edge from each of the new nodes (including this one)
@@ -146,7 +177,7 @@ fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
 	newContexts = [ (v, to v) | v <- newNodes ]
 
 alphabet :: Eq b => Graph n a (Maybe b) -> [b]
-alphabet = nub . catMaybes . map getLabel . edges
+alphabet = nub . catMaybes . map edgeLabel . edges
 
 determinize :: Ord a => NFA a -> DFA a
 determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.empty
@@ -154,9 +185,9 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
                              final = filter isDFAFinal ns'
                              fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
  		          in renameStates [0..] fa
-  where out = outgoing g
+  where info = nodeInfo g
 --        reach = nodesReachable out
-	start = closure out $ Set.singleton s
+	start = closure info $ Set.singleton s
         isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n))
 	h currentStates oldStates es
 	    | Set.null currentStates = (oldStates,es)
@@ -169,43 +200,28 @@ determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.emp
         -- by consuming one symbol, and the associated edges.
         new [] rs es = (rs,es)
         new (n:ns) rs es = new ns rs' es'
-          where cs = reachable out n --reachable reach n
+          where cs = reachable info n --reachable reach n
                 rs' = rs `Set.union` Set.fromList (map snd cs)
                 es' = es `Set.union` Set.fromList [(n,s,c) | (c,s) <- cs]
 
 
 -- | Get all the nodes reachable from a list of nodes by only empty edges.
-closure :: Ord n => Outgoing n a (Maybe b) -> Set n -> Set n
-closure out x = closure_ x x
+closure :: Ord n => NodeInfo n a (Maybe b) -> Set n -> Set n
+closure info x = closure_ x x
   where closure_ acc check | Set.null check = acc
                            | otherwise = closure_ acc' check'
             where
             reach = Set.fromList [y | x <- Set.toList check, 
-                                      (_,y,Nothing) <- getOutgoing out x]
+                                      (_,y,Nothing) <- getOutgoing info x]
             acc' = acc `Set.union` reach
             check' = reach Set.\\ acc
 
 -- | Get a map of labels to sets of all nodes reachable
 --   from a the set of nodes by one edge with the given
 --   label and then any number of empty edges.
-reachable :: (Ord n,Ord b) => Outgoing n a (Maybe b) -> Set n -> [(b,Set n)]
-reachable out ns = Map.toList $ Map.map (closure out . Set.fromList) $ reachable1 out ns
-reachable1 out ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,Just c) <- getOutgoing out n]
-
-
-{-
--- Alternative implementation of reachable, seems to use too much memory.
-
-type Reachable n b = Map n (Map b (Set n))
-
-reachable :: (Ord n, Ord b) => Reachable n b -> Set n -> [(b,Set n)]
-reachable r ns = Map.toList $ Map.unionsWith Set.union $ lookups (Set.toList ns) r
-
-nodesReachable :: (Ord n, Ord b) => Outgoing n a (Maybe b) -> Reachable n b
-nodesReachable out = Map.map (f . snd) out
-  where f = Map.map (closure out . Set.fromList) . edgesByLabel
-        edgesByLabel es = Map.fromListWith (++) [(c,[y]) | (_,y,Just c) <- es]
--}
+reachable :: (Ord n,Ord b) => NodeInfo n a (Maybe b) -> Set n -> [(b,Set n)]
+reachable info ns = Map.toList $ Map.map (closure info . Set.fromList) $ reachable1 info ns
+reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,Just c) <- getOutgoing info n]
 
 reverseNFA :: NFA a -> NFA a
 reverseNFA (FA g s fs) = FA g''' s' [s]
diff --git a/src/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs
index 84ac6d114..689880799 100644
--- a/src/GF/Speech/Graph.hs
+++ b/src/GF/Speech/Graph.hs
@@ -11,21 +11,24 @@
 --
 -- A simple graph module.
 -----------------------------------------------------------------------------
-module GF.Speech.Graph ( Graph(..), Node, Edge, Incoming, Outgoing
+module GF.Speech.Graph ( Graph(..), Node, Edge, NodeInfo
                         , newGraph, nodes, edges
                         , nmap, emap, newNode, newNodes, newEdge, newEdges
-                        , incoming, incomingToList
-                        , outgoing, getOutgoing
-                        , getFrom, getTo, getLabel
+                        , removeNodes
+                        , nodeInfo
+                        , getIncoming, getOutgoing, getNodeLabel
+                        , edgeFrom, edgeTo, edgeLabel
                         , reverseGraph, renameNodes
                        ) where
 
 import GF.Data.Utilities
 
 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
 
 data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
 		 deriving (Eq,Show)
@@ -33,15 +36,17 @@ data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
 type Node n a = (n,a)
 type Edge n b = (n,n,b)
 
-type Incoming n a b = Map n (a, [Edge n b])
-type Outgoing n a b = Map n (a, [Edge n b])
+type NodeInfo n a b = Map n (a, [Edge n b], [Edge n b])
 
+-- | Create a new empty graph.
 newGraph :: [n] -> Graph n a b
 newGraph ns = Graph ns [] []
 
+-- | Get all the nodes in the graph.
 nodes :: Graph n a b -> [Node n a]
 nodes (Graph _ ns _) = ns
 
+-- | Get all the edges in the graph.
 edges :: Graph n a b -> [Edge n b]
 edges (Graph _ _ es) = es
 
@@ -53,7 +58,10 @@ 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)
+-- | Add a node to the graph.
+newNode :: a               -- ^ Node label
+        -> Graph n a b 
+        -> (Graph n a b,n) -- ^ Node graph and name of new node
 newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
 
 newNodes :: [a] -> Graph n a b -> (Graph n a b,[Node n a])
@@ -72,10 +80,47 @@ newEdges es g = foldl' (flip newEdge) g es
 -- lazy version:
 -- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
 
+-- | Remove a set of nodes and all edges to and from those nodes.
+removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
+removeNodes xs (Graph c ns es) = Graph c ns' es'
+  where 
+  keepNode n = not (Set.member n xs)
+  ns' = [ x | x@(n,_) <- ns, keepNode n ]
+  es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
+
+-- | Get a map of node names to info about each node.
+nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
+nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
+  where 
+  inc = groupEdgesBy edgeTo g
+  out = groupEdgesBy edgeFrom g
+  fn m n = fromMaybe [] (Map.lookup n m)
+
+groupEdgesBy :: (Ord n) => (Edge n b -> n) -- ^ Gets the node to group by
+             -> Graph n a b -> Map n [Edge n b]
+groupEdgesBy f g = Map.fromListWith (++) [(f e, [e]) | e <- edges g]
+
+lookupNode :: Ord n => NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
+lookupNode i n = fromJust $ Map.lookup n i
+
+getIncoming :: Ord n => NodeInfo n a b -> n -> [Edge n b]
+getIncoming i n = let (_,inc,_) = lookupNode i n in inc
+
+getOutgoing :: Ord n => NodeInfo n a b -> n -> [Edge n b]
+getOutgoing i n = let (_,_,out) = lookupNode i n in out
+
+getNodeLabel :: Ord n => NodeInfo n a b -> n -> a
+getNodeLabel i n = let (l,_,_) = lookupNode i n in l
+
+{-
 -- | Get a map of nodes and their incoming edges.
 incoming :: Ord n => Graph n a b -> Incoming n a b
 incoming = groupEdgesBy getTo
 
+-- | Get all edges ending at a given node.
+getIncoming :: Ord n => Incoming n a b -> n -> [Edge n b]
+getIncoming out x = maybe [] snd (Map.lookup x out)
+
 incomingToList :: Incoming n a b -> [(Node n a, [Edge n b])]
 incomingToList out = [ ((n,x),es) | (n,(x,es)) <- Map.toList out ]
 
@@ -87,19 +132,24 @@ outgoing = groupEdgesBy getFrom
 getOutgoing :: Ord n => Outgoing n a b -> n -> [Edge n b]
 getOutgoing out x = maybe [] snd (Map.lookup x out)
 
+-- | Get the label of a node given its outgoing list.
+getLabelOut :: Ord n => Outgoing n a b -> n -> a
+getLabelOut out x = fst $ fromJust (Map.lookup x out)
+
 groupEdgesBy :: (Ord n) => (Edge n b -> n) -> Graph n a b -> Map n (a,[Edge n b])
 groupEdgesBy f (Graph _ ns es) = 
     foldl' (\m e -> Map.adjust (\ (x,el) -> (x,e:el)) (f e) m) nm es
   where nm = Map.fromList [ (n, (x,[])) | (n,x) <- ns ]
+-}
 
-getFrom :: Edge n b -> n
-getFrom (f,_,_) = f
+edgeFrom :: Edge n b -> n
+edgeFrom (f,_,_) = f
 
-getTo :: Edge n b -> n
-getTo (_,t,_) = t
+edgeTo :: Edge n b -> n
+edgeTo (_,t,_) = t
 
-getLabel :: Edge n b -> b
-getLabel (_,_,l) = l
+edgeLabel :: Edge n b -> b
+edgeLabel (_,_,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/PrSLF.hs b/src/GF/Speech/PrSLF.hs
index a47057c80..bb8f5ddaf 100644
--- a/src/GF/Speech/PrSLF.hs
+++ b/src/GF/Speech/PrSLF.hs
@@ -86,7 +86,7 @@ mapMFA :: (DFA (MFALabel a) -> b) -> MFA a -> (b,[(String,b)])
 mapMFA f (MFA main subs) = (f main, [(c, f fa) | (c,fa) <- subs])
 
 slfStyleFA :: DFA (MFALabel String) -> SLF_FA
-slfStyleFA = oneFinalState Nothing () . moveLabelsToNodes . dfa2nfa
+slfStyleFA = removeTrivialEmptyNodes . oneFinalState Nothing () . moveLabelsToNodes . dfa2nfa
 
 mfaToSLFs :: MFA String -> SLFs
 mfaToSLFs (MFA main subs)