From 6958b7bb7b275f8800072a2f1bfeca51d05600bb Mon Sep 17 00:00:00 2001
From: bringert <bringert@cs.chalmers.se>
Date: Thu, 5 Jan 2006 16:48:55 +0000
Subject: [PATCH] Remove more unneccessary nodes in SLF networks.

---
 src/GF/Speech/FiniteState.hs | 33 ++++++++++++++++++---------------
 src/GF/Speech/Graph.hs       |  7 +++++++
 2 files changed, 25 insertions(+), 15 deletions(-)

diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index ab2aed838..094806b0d 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/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.
-skipEmptyNodes :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) ()
-skipEmptyNodes = onGraph og
+-- | Move edges to empty nodes with exactly one outgoing edge 
+--   or exactly one incoming edge to point to the next node(s).
+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) 
-          = case getOutgoing info t of
-                [(_,t',())] -> (f,t',())
-                _ -> e
-      | otherwise = e
+      | isNothing (getNodeLabel info t)
+        && (inDegree info t == 1 || outDegree info t == 1)
+          = [ (f,t',()) | (_,t',()) <- getOutgoing info t]
+      | 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
+-- | Remove all internal nodes with no incoming edges
+--   or no outgoing edges.
+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] 
diff --git a/src/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs
index 689880799..d018756d7 100644
--- a/src/GF/Speech/Graph.hs
+++ b/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