msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

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

Browse Source
This commit is contained in:
bringert
2005-12-29 20:24:34 +00:00
parent 72c2289857
commit 79d771ab1d
3 changed files with 66 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files

23
src/GF/Speech/CFGToFiniteState.hs
View File

@@ -110,7 +110,7 @@ mutRecSets g = Map.fromList . concatMap mkMutRecSet
make_fa :: (CFRules,MutRecSets) -> State -> [Symbol Cat_ Token] -> State make_fa :: (CFRules,MutRecSets) -> State -> [Symbol Cat_ Token] -> State
-> NFA Token -> NFA Token -> NFA Token -> NFA Token
make_fa c@(g,ns) q0 alpha q1 fa = make_fa c@(g,ns) q0 alpha q1 fa =
case alpha of case alpha of
[] -> newTransition q0 q1 Nothing fa [] -> newTransition q0 q1 Nothing fa
[Tok t] -> newTransition q0 q1 (Just t) fa [Tok t] -> newTransition q0 q1 (Just t) fa
[Cat a] -> case Map.lookup a ns of [Cat a] -> case Map.lookup a ns of
@@ -119,16 +119,15 @@ make_fa c@(g,ns) q0 alpha q1 fa =
if mrIsRightRec n if mrIsRightRec n
then then
-- the set Ni is right-recursive or cyclic -- the set Ni is right-recursive or cyclic
let fa'' = foldl (\ f (CFRule c xs _) -> make_fa_ (getState c) xs q1 f) fa' nrs let new = [(getState c, xs, q1) | CFRule c xs _ <- nrs]
fa''' = foldl (\ f (CFRule c ss _) -> ++ [(getState c, xs, getState d) | CFRule c ss _ <- rs,
let (xs,Cat d) = (init ss,last ss) let (xs,Cat d) = (init ss,last ss)]
in make_fa_ (getState c) xs (getState d) f) fa'' rs in make_fas new $ newTransition q0 (getState a) Nothing fa'
in newTransition q0 (getState a) Nothing fa'''
else else
-- the set Ni is left-recursive -- the set Ni is left-recursive
let fa'' = foldl (\f (CFRule c xs _) -> make_fa_ q0 xs (getState c) f) fa' nrs let new = [(q0, xs, getState c) | CFRule c xs _ <- nrs]
fa''' = foldl (\f (CFRule c (Cat d:xs) _) -> make_fa_ (getState d) xs (getState c) f) fa'' rs ++ [(getState d, xs, getState c) | CFRule c (Cat d:xs) _ <- rs]
in newTransition (getState a) q1 Nothing fa''' in make_fas new $ newTransition (getState a) q1 Nothing fa'
where where
(fa',stateMap) = addStatesForCats ni fa (fa',stateMap) = addStatesForCats ni fa
getState x = Map.findWithDefault getState x = Map.findWithDefault
@@ -136,11 +135,13 @@ make_fa c@(g,ns) q0 alpha q1 fa =
x stateMap x stateMap
-- a is not recursive -- a is not recursive
Nothing -> let rs = catRules g a 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 (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 where
make_fa_ = make_fa c 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 :: [Cat_] -> NFA Token -> (NFA Token, Map Cat_ State)
addStatesForCats cs fa = (fa', m) addStatesForCats cs fa = (fa', m)

55
src/GF/Speech/FiniteState.hs
View File

@@ -25,19 +25,23 @@ module GF.Speech.FiniteState (FA, State, NFA, DFA,
prFAGraphviz) where prFAGraphviz) where
import Data.List import Data.List
import Data.Maybe (catMaybes,fromJust) import Data.Maybe (catMaybes,fromJust,isNothing)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Set as StateSet
import GF.Data.Utilities import GF.Data.Utilities
import GF.Speech.Graph import GF.Speech.Graph
import qualified GF.Visualization.Graphviz as Dot import qualified GF.Visualization.Graphviz as Dot
type State = Int 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) 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 :: (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 onGraph f (FA g s ss) = FA (f g) s ss
-- | Make the finite automaton have a single final state -- | Make the finite automaton have a single final state
-- by adding a new final state and adding an edge -- by adding a new final state and adding an edge
-- from the old final states to the new state. -- 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 alphabet = nub . catMaybes . map getLabel . edges
determinize :: Ord a => NFA a -> DFA a determinize :: Ord a => NFA a -> DFA a
determinize (FA g s f) = let (ns,es) = h [start] [] [] determinize (FA g s f) = let (ns,es) = h (Set.singleton start) Set.empty Set.empty
final = filter isDFAFinal ns (ns',es') = (Set.toList ns, Set.toList es)
fa = FA (Graph undefined [(n,()) | n <- ns] es) start final final = filter isDFAFinal ns'
fa = FA (Graph undefined [(n,()) | n <- ns'] es') start final
in numberStates fa in numberStates fa
where out = outgoing g where out = outgoing g
start = closure out $ Set.singleton s start = closure out $ StateSet.singleton s
isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n)) isDFAFinal n = not (StateSet.null (StateSet.fromList f `StateSet.intersection` n))
h currentStates oldStates oldEdges h currentStates oldStates es
| null currentStates = (oldStates,oldEdges) | Set.null currentStates = (oldStates,es)
| otherwise = h uniqueNewStates allOldStates (newEdges++oldEdges) | otherwise = h uniqueNewStates allOldStates es'
where where
allOldStates = currentStates ++ oldStates allOldStates = oldStates `Set.union` currentStates
(newStates,newEdges) (newStates,es') = new (Set.toList currentStates) Set.empty es
= unzip [ (s, (n,s,c)) | n <- currentStates, (c,s) <- reachable out n] uniqueNewStates = newStates Set.\\ allOldStates
uniqueNewStates = nub newStates \\ 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 :: (Ord x,Enum y) => FA x a b -> FA y a b
numberStates (FA g s fs) = FA (renameNodes newName rest g) s' fs' 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 fs' = map newName fs
-- | Get all the nodes reachable from a list of nodes by only empty edges. -- | 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 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' | otherwise = closure_ acc' check'
where where
reach = Set.fromList [y | x <- Set.toList check, reach = StateSet.fromList [y | x <- StateSet.toList check,
(_,y,Nothing) <- getOutgoing out x] (_,y,Nothing) <- getOutgoing out x]
acc' = acc `Set.union` reach acc' = acc `StateSet.union` reach
check' = reach Set.\\ acc check' = reach StateSet.\\ acc
-- | Get a map of labels to sets of all nodes reachable -- | Get a map of labels to sets of all nodes reachable
-- from a the set of nodes by one edge with the given -- from a the set of nodes by one edge with the given
-- label and then any number of empty edges. -- label and then any number of empty edges.
reachable :: (Ord n, Ord b) => Outgoing n a (Maybe b) -> Set n -> [(b,Set n)] reachable :: Ord b => Outgoing State a (Maybe b) -> StateSet -> [(b,StateSet)]
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 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 :: NFA a -> NFA a
reverseNFA (FA g s fs) = FA g''' s' [s] reverseNFA (FA g s fs) = FA g''' s' [s]

30
src/GF/Speech/Graph.hs
View File

@@ -27,7 +27,7 @@ import Data.List
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as 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) deriving (Eq,Show)
type Node n a = (n,a) type Node n a = (n,a)
@@ -45,7 +45,7 @@ nodes (Graph _ ns _) = ns
edges :: Graph n a b -> [Edge n b] edges :: Graph n a b -> [Edge n b]
edges (Graph _ _ es) = es 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 :: (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 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) 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 :: [a] -> Graph n a b -> (Graph n a b,[Node n a])
newNodes ls (Graph cs ns es) = (Graph cs' (ns'++ns) es, ns') newNodes ls g = (g', zip ns ls)
where (xs,cs') = splitAt (length ls) cs where (g',ns) = mapAccumL (flip newNode) g ls
ns' = zip xs 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 :: Edge n b -> Graph n a b -> Graph n a b
newEdge e (Graph c ns es) = Graph c ns (e:es) newEdge e (Graph c ns es) = Graph c ns (e:es)
newEdges :: [Edge n b] -> Graph n a b -> Graph n a b 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. -- | Get a map of nodes and their incoming edges.
incoming :: Ord n => Graph n a b -> Incoming n a b 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 :: (Ord n) => (Edge n b -> n) -> Graph n a b -> Map n (a,[Edge n b])
groupEdgesBy f (Graph _ ns es) = 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 ] where nm = Map.fromList [ (n, (x,[])) | (n,x) <- ns ]
getFrom :: Edge n b -> n 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 ] 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 renameNodes :: (n -> m) -- ^ renaming function
-> [m] -- ^ infinite supply of fresh node names, to -> [m] -- ^ infinite supply of fresh node names, to
-- use when adding nodes in the future. -- use when adding nodes in the future.
-> Graph n a b -> Graph m a b -> Graph n a b -> Graph m a b
renameNodes newName c (Graph _ ns es) = Graph c ns' es' renameNodes newName c (Graph _ ns es) = Graph c ns' es'
where ns' = [ (newName n,x) | (n,x) <- ns ] where ns' = map' (\ (n,x) -> (newName n,x)) ns
es' = [ (newName f, newName t, l) | (f,t,l) <- es] 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