diff options
| author | bringert <bringert@cs.chalmers.se> | 2005-12-29 20:24:34 +0000 |
|---|---|---|
| committer | bringert <bringert@cs.chalmers.se> | 2005-12-29 20:24:34 +0000 |
| commit | d8548908202488db2934ed7a51924844c2936ee0 (patch) | |
| tree | baee6356b52f86dad1fc4817647f939947b986b9 /src/GF/Speech/CFGToFiniteState.hs | |
| parent | f4f1f04123d7dc33e9be65dd8c929bd4a21e193a (diff) | |
Fintie state networks: fixed stack overflow problem with strictness in Graph and FiniteState. Some clean-up and smaller performance fixes.
Diffstat (limited to 'src/GF/Speech/CFGToFiniteState.hs')
| -rw-r--r-- | src/GF/Speech/CFGToFiniteState.hs | 23 |
1 files changed, 12 insertions, 11 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) |