diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Speech/FiniteState.hs | 33 | ||||
| -rw-r--r-- | 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 |