Remove more unneccessary nodes in SLF networks.

src/GF/Speech/FiniteState.hs

@@ -128,34 +128,37 @@ moveLabelsToNodes = onGraph f
 
 
 -- | Remove empty nodes which are not start or final, and have
---   exactly one outgoing edge.
+--   exactly one outgoing edge or exactly one incoming edge.
 removeTrivialEmptyNodes :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
-removeTrivialEmptyNodes = pruneUnreachable . skipEmptyNodes
+removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes
 
--- | Move edges to empty nodes with one outgoing edge to the next edge.
+-- | Move edges to empty nodes with exactly one outgoing edge 
-skipEmptyNodes :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
+--   or exactly one incoming edge to point to the next node(s).
-skipEmptyNodes = onGraph og
+skipSimpleEmptyNodes :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
+skipSimpleEmptyNodes = onGraph og
   where 
-  og g@(Graph c ns es) = Graph c ns (map changeEdge es)
+  og g@(Graph c ns es) = Graph c ns (concatMap changeEdge es)
     where
     info = nodeInfo g
     changeEdge e@(f,t,()) 
-      | isNothing (getNodeLabel info t) 
+      | isNothing (getNodeLabel info t)
-          = case getOutgoing info t of
+        && (inDegree info t == 1 || outDegree info t == 1)
-                [(_,t',())] -> (f,t',())
+          = [ (f,t',()) | (_,t',()) <- getOutgoing info t]
-                _ -> e
+      | otherwise = [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.
+-- | Remove all internal nodes with no incoming edges
-pruneUnreachable :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
+--   or no outgoing edges.
-pruneUnreachable fa = onGraph f fa
+pruneUnusable :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
+pruneUnusable fa = onGraph f fa
  where
  f g = removeNodes (Set.fromList [ n | (n,_) <- nodes g, 
                                    isInternal fa n,
-                                   null (getIncoming info n)]) g
+                                   inDegree info n == 0 
+                                    || outDegree info n == 0]) g
   where info = nodeInfo g
 
 fixIncoming :: (Ord n, Eq a) => [n] 

src/GF/Speech/Graph.hs

@@ -17,6 +17,7 @@ module GF.Speech.Graph ( Graph(..), Node, Edge, NodeInfo
                         , removeNodes
                         , nodeInfo
                         , getIncoming, getOutgoing, getNodeLabel
+                        , inDegree, outDegree
                         , edgeFrom, edgeTo, edgeLabel
                         , reverseGraph, renameNodes
                        ) where
@@ -109,6 +110,12 @@ 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
 
+inDegree :: Ord n => NodeInfo n a b -> n -> Int
+inDegree i n = length $ getIncoming i n
+
+outDegree :: Ord n => NodeInfo n a b -> n -> Int
+outDegree i n = length $ getOutgoing i n
+
 getNodeLabel :: Ord n => NodeInfo n a b -> n -> a
 getNodeLabel i n = let (l,_,_) = lookupNode i n in l