mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-10 13:29:32 -06:00
Fintie state networks: fixed stack overflow problem with strictness in Graph and FiniteState. Some clean-up and smaller performance fixes.
This commit is contained in:
bringert
@@ -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)
|
||||
|
||||
@@ -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]
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user