Finite state network generation: reimplemented getOutgoing using Data.Map to improve performance of minimize with large networks.

2 files changed, 22 insertions, 16 deletions

diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index a2f8952cb..146bb6631 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/src/GF/Speech/FiniteState.hs
@@ -103,7 +103,7 @@ oneFinalState nl el fa =
 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 = incoming gr
+	    where is = incomingToList $ incoming gr
 		  (c',is') = mapAccumL fixIncoming c is
 		  (ns,ess) = unzip (concat is')
 
@@ -112,7 +112,7 @@ moveLabelsToNodes = removeTrivialEmptyNodes . onGraph f
 removeTrivialEmptyNodes :: FA n (Maybe a) () -> FA n (Maybe a) ()
 removeTrivialEmptyNodes = id -- FIXME: implement
 
-fixIncoming :: (Eq n, Eq a) => [n] -> (Node n (),[Edge n (Maybe a)]) -> ([n],[(Node n (Maybe a),[Edge n ()])])
+fixIncoming :: (Ord n, Eq a) => [n] -> (Node n (),[Edge n (Maybe a)]) -> ([n],[(Node n (Maybe a),[Edge n ()])])
 fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts)
   where ls = nub $ map getLabel es
 	(cs',cs'') = splitAt (length ls) cs
@@ -156,7 +156,7 @@ numberStates (FA g s fs) = FA (renameNodes newName rest g) s' fs'
           fs' = map newName fs
 
 -- | Get all the nodes reachable from a set of nodes by only empty edges.
-closure :: Eq n => Outgoing n a (Maybe b) -> [n] -> [n]
+closure :: Ord n => Outgoing n a (Maybe b) -> [n] -> [n]
 closure out = fix closure_
     where closure_ r = r `union` [y | x <- r, (_,y,Nothing) <- getOutgoing out x]
 
diff --git a/src/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs
index 7ebecdc34..4a4b210e5 100644
--- a/src/GF/Speech/Graph.hs
+++ b/src/GF/Speech/Graph.hs
@@ -14,7 +14,8 @@
 module GF.Speech.Graph ( Graph(..), Node, Edge, Incoming, Outgoing
                         , newGraph, nodes, edges
                         , nmap, emap, newNode, newNodes, newEdge, newEdges
-                        , incoming, outgoing, getOutgoing
+                        , incoming, incomingToList
+                        , outgoing, getOutgoing
                         , getFrom, getTo, getLabel
                         , reverseGraph, renameNodes
                        ) where
@@ -23,14 +24,17 @@ import GF.Data.Utilities
 
 import Data.List
 
+import Data.Map (Map)
+import qualified Data.Map as Map
+
 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])]
+type Incoming n a b = Map n (a, [Edge n b])
+type Outgoing n a b = Map n (a, [Edge n b])
 
 newGraph :: [n] -> Graph n a b
 newGraph ns = Graph ns [] []
@@ -63,23 +67,25 @@ 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.
+-- | Get a map of 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.
+incomingToList :: Incoming n a b -> [(Node n a, [Edge n b])]
+incomingToList out = [ ((n,x),es) | (n,(x,es)) <- Map.toList out ]
+
+-- | Get a map of 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 ]
+-- | Get all edges starting at a given node.
+getOutgoing :: Ord n => Outgoing n a b -> n -> [Edge n b]
+getOutgoing out x = maybe [] snd (Map.lookup x out)
 
-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))
+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