Fintie state networks: fixed stack overflow problem with strictness in Graph and FiniteState. Some clean-up and smaller performance fixes.

3 files changed, 66 insertions, 42 deletions

diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs
index 5f8e3a093..c12f13b39 100644
--- a/src/GF/Speech/CFGToFiniteState.hs
+++ b/src/GF/Speech/CFGToFiniteState.hs
@@ -110,7 +110,7 @@ mutRecSets g = Map.fromList . concatMap mkMutRecSet
 make_fa :: (CFRules,MutRecSets) -> State -> [Symbol Cat_ Token] -> State 
           -> NFA Token -> NFA Token
 make_fa c@(g,ns) q0 alpha q1 fa = 
-     case alpha of
+   case alpha of
         []       -> newTransition q0 q1 Nothing fa
         [Tok t]  -> newTransition q0 q1 (Just t) fa
         [Cat a]  -> case Map.lookup a ns of
@@ -119,16 +119,15 @@ make_fa c@(g,ns) q0 alpha q1 fa =
                               if mrIsRightRec n
                                then
                                 -- the set Ni is right-recursive or cyclic
-                                let fa''  = foldl (\ f (CFRule c xs _) -> make_fa_ (getState c) xs q1 f) fa' nrs
-                                    fa''' = foldl (\ f (CFRule c ss _) -> 
-                                                       let (xs,Cat d) = (init ss,last ss)
-                                                        in make_fa_ (getState c) xs (getState d) f) fa'' rs
-                                 in newTransition q0 (getState a) Nothing fa'''
+                                let new = [(getState c, xs, q1) | CFRule c xs _ <- nrs]
+                                          ++ [(getState c, xs, getState d) | CFRule c ss _ <- rs, 
+                                                                             let (xs,Cat d) = (init ss,last ss)]
+                                 in make_fas new $ newTransition q0 (getState a) Nothing fa'
                                else
                                 -- the set Ni is left-recursive
-                                let fa'' = foldl (\f (CFRule c xs _) -> make_fa_ q0 xs (getState c) f) fa' nrs
-                                    fa''' = foldl (\f (CFRule c (Cat d:xs) _) -> make_fa_ (getState d) xs (getState c) f) fa'' rs
-                                in newTransition (getState a) q1 Nothing fa'''
+                                let new = [(q0, xs, getState c) | CFRule c xs _ <- nrs]
+                                          ++ [(getState d, xs, getState c) | CFRule c (Cat d:xs) _ <- rs]
+                                 in make_fas new $ newTransition (getState a) q1 Nothing fa'
                           where
                           (fa',stateMap) = addStatesForCats ni fa
                           getState x = Map.findWithDefault 
@@ -136,11 +135,13 @@ make_fa c@(g,ns) q0 alpha q1 fa =
                                        x stateMap
                         -- a is not recursive
                         Nothing -> let rs = catRules g a
-                                    in foldl (\fa -> \ (CFRule _ b _) -> make_fa_ q0 b q1 fa) fa rs
+                                    in foldl' (\f (CFRule _ b _) -> make_fa_ q0 b q1 f) fa rs
         (x:beta) -> let (fa',q) = newState () fa
-                     in make_fa_ q beta q1 $! make_fa_ q0 [x] q fa'
+                     in make_fa_ q beta q1 $ make_fa_ q0 [x] q fa'
   where
   make_fa_ = make_fa c
+  make_fas xs fa = foldl' (\f' (s1,xs,s2) -> make_fa_ s1 xs s2 f') fa xs
+
 
 addStatesForCats :: [Cat_] -> NFA Token -> (NFA Token, Map Cat_ State)
 addStatesForCats cs fa = (fa', m)
diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index e48064945..b2ac0fee3 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/src/GF/Speech/FiniteState.hs
@@ -25,19 +25,23 @@ module GF.Speech.FiniteState (FA, State, NFA, DFA,
 			      prFAGraphviz) where
 
 import Data.List
-import Data.Maybe (catMaybes,fromJust)
+import Data.Maybe (catMaybes,fromJust,isNothing)
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
 
+import qualified Data.Set as StateSet
+
 import GF.Data.Utilities
 import GF.Speech.Graph
 import qualified GF.Visualization.Graphviz as Dot
 
 type State = Int
 
-data FA n a b = FA (Graph n a b) n [n]
+type StateSet = StateSet.Set State
+
+data FA n a b = FA !(Graph n a b) !n ![n]
 
 type NFA a = FA State () (Maybe a)
 
@@ -87,6 +91,7 @@ minimize = determinize . reverseNFA . dfa2nfa . determinize . reverseNFA
 onGraph :: (Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
 onGraph f (FA g s ss) = FA (f g) s ss
 
+
 -- | Make the finite automaton have a single final state
 --   by adding a new final state and adding an edge
 --   from the old final states to the new state.
@@ -133,21 +138,28 @@ alphabet :: Eq b => Graph n a (Maybe b) -> [b]
 alphabet = nub . catMaybes . map getLabel . edges
 
 determinize :: Ord a => NFA a -> DFA a
-determinize (FA g s f) = let (ns,es) = h [start] [] []
-                             final = filter isDFAFinal ns
-                             fa = FA (Graph undefined [(n,()) | n <- ns] es) start final
+determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.empty
+                             (ns',es') = (Set.toList ns, Set.toList es)
+                             final = filter isDFAFinal ns'
+                             fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
  		          in numberStates fa
   where out = outgoing g
-	start = closure out $ Set.singleton s
-        isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n))
-	h currentStates oldStates oldEdges 
-	    | null currentStates = (oldStates,oldEdges)
-	    | otherwise = h uniqueNewStates allOldStates (newEdges++oldEdges)
+	start = closure out $ StateSet.singleton s
+        isDFAFinal n = not (StateSet.null (StateSet.fromList f `StateSet.intersection` n))
+	h currentStates oldStates es
+	    | Set.null currentStates = (oldStates,es)
+	    | otherwise = h uniqueNewStates allOldStates es'
 	    where 
-	    allOldStates = currentStates ++ oldStates
-            (newStates,newEdges) 
-                = unzip [ (s, (n,s,c)) | n <- currentStates, (c,s) <- reachable out n]
-	    uniqueNewStates = nub newStates \\ allOldStates
+	    allOldStates = oldStates `Set.union` currentStates
+            (newStates,es') = new (Set.toList currentStates) Set.empty es
+	    uniqueNewStates = newStates Set.\\ allOldStates
+        -- Get the sets of states reachable from the given states 
+        -- 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
+                rs' = rs `Set.union` Set.fromList (map snd cs)
+                es' = es `Set.union` Set.fromList [(n,s,c) | (c,s) <- cs]
 
 numberStates :: (Ord x,Enum y) => FA x a b -> FA y a b
 numberStates (FA g s fs) = FA (renameNodes newName rest g) s' fs'
@@ -158,21 +170,22 @@ numberStates (FA g s fs) = FA (renameNodes newName rest g) s' fs'
           fs' = map newName fs
 
 -- | 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 :: Outgoing State a (Maybe b) -> StateSet -> StateSet
 closure out x = closure_ x x
-  where closure_ acc check | Set.null check = acc
+  where closure_ acc check | StateSet.null check = acc
                            | otherwise = closure_ acc' check'
             where
-            reach = Set.fromList [y | x <- Set.toList check, 
+            reach = StateSet.fromList [y | x <- StateSet.toList check, 
                                       (_,y,Nothing) <- getOutgoing out x]
-            acc' = acc `Set.union` reach
-            check' = reach Set.\\ acc
+            acc' = acc `StateSet.union` reach
+            check' = reach StateSet.\\ 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) $ Map.fromListWith (++) [(c,[y]) | n <- Set.toList ns, (_,y,Just c) <- getOutgoing out n]
+reachable :: Ord b => Outgoing State a (Maybe b) -> StateSet -> [(b,StateSet)]
+reachable out ns = Map.toList $ Map.map (closure out . StateSet.fromList) $ reachable1 out ns
+reachable1 out ns = Map.fromListWith (++) [(c, [y]) | n <- StateSet.toList ns, (_,y,Just c) <- getOutgoing out 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 4a4b210e5..84ac6d114 100644
--- a/src/GF/Speech/Graph.hs
+++ b/src/GF/Speech/Graph.hs
@@ -27,7 +27,7 @@ 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]
+data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
 		 deriving (Eq,Show)
 
 type Node n a = (n,a)
@@ -45,7 +45,7 @@ nodes (Graph _ ns _) = ns
 edges :: Graph n a b -> [Edge n b]
 edges (Graph _ _ es) = es
 
--- | Map a function over the node label.s
+-- | Map a function over the node labels.
 nmap :: (a -> c) -> Graph n a b -> Graph n c b
 nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
 
@@ -57,15 +57,20 @@ newNode :: a -> Graph n a b -> (Graph n a b,n)
 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])
-newNodes ls (Graph cs ns es) = (Graph cs' (ns'++ns) es, ns')
-  where (xs,cs') = splitAt (length ls) cs
-        ns' = zip xs ls
+newNodes ls g = (g', zip ns ls)
+  where (g',ns) = mapAccumL (flip newNode) g ls
+-- lazy version:
+--newNodes ls (Graph cs ns es) = (Graph cs' (ns'++ns) es, ns')
+--  where (xs,cs') = splitAt (length ls) cs
+--        ns' = zip xs ls
 
 newEdge :: Edge n b -> Graph n a b -> Graph n a b
 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)
+newEdges es g = foldl' (flip newEdge) g es
+-- lazy version:
+-- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
 
 -- | Get a map of nodes and their incoming edges.
 incoming :: Ord n => Graph n a b -> Incoming n a b
@@ -84,7 +89,7 @@ getOutgoing out x = maybe [] snd (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
+    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
@@ -100,11 +105,16 @@ reverseGraph :: Graph n a b -> Graph n a b
 reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
 
 
--- | Re-name the nodes in the graph.
+-- | Rename the nodes in the graph.
 renameNodes :: (n -> m) -- ^ renaming function
             -> [m] -- ^ infinite supply of fresh node names, to
                    --   use when adding nodes in the future.
             -> Graph n a b -> Graph m a b
 renameNodes newName c (Graph _ ns es) = Graph c ns' es'
-    where ns' = [ (newName n,x) | (n,x) <- ns ]
-	  es' = [ (newName f, newName t, l) | (f,t,l) <- es]
+    where ns' = map' (\ (n,x) -> (newName n,x)) ns
+	  es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
+
+-- | A strict 'map'
+map' :: (a -> b) -> [a] -> [b]
+map' _ [] = []
+map' f (x:xs) = ((:) $! f x) $! map' f xs