diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs index 7bc5040fd..fbe6c6a27 100644 --- a/src/GF/Data/Utilities.hs +++ b/src/GF/Data/Utilities.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/14 18:00:19 $ +-- > CVS $Date: 2005/09/22 16:56:05 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ +-- > CVS $Revision: 1.5 $ -- -- Basic functions not in the standard libraries ----------------------------------------------------------------------------- @@ -80,11 +80,15 @@ sortNub = map head . group . sort unionAll :: Eq a => [[a]] -> [a] unionAll = nub . concat --- | Like lookup, but fails if the argument is not found, +-- | Like 'lookup', but fails if the argument is not found, -- instead of returning Nothing. lookup' :: Eq a => a -> [(a,b)] -> b lookup' x = fromJust . lookup x +-- | Like 'find', but fails if nothing is found. +find' :: (a -> Bool) -> [a] -> a +find' p = fromJust . find p + -- * ordering functions compareBy :: Ord b => (a -> b) -> a -> a -> Ordering diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs index f897c1425..66e007fd9 100644 --- a/src/GF/Speech/FiniteState.hs +++ b/src/GF/Speech/FiniteState.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/15 18:10:44 $ +-- > CVS $Date: 2005/09/22 16:56:05 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.11 $ +-- > CVS $Revision: 1.12 $ -- -- A simple finite state network module. ----------------------------------------------------------------------------- @@ -21,7 +21,6 @@ module GF.Speech.FiniteState (FA, State, NFA, DFA, moveLabelsToNodes, minimize, prFAGraphviz) where -import GF.Data.Utilities import Data.List import Data.Maybe (catMaybes,fromJust) @@ -62,7 +61,7 @@ newState x (FA g s ss) = (FA g' s ss, n) where (g',n) = newNode x g newTransition :: n -> n -> b -> FA n a b -> FA n a b -newTransition f t l = onGraph (newEdge f t l) +newTransition f t l = onGraph (newEdge (f,t,l)) mapStates :: (a -> c) -> FA n a b -> FA n c b mapStates f = onGraph (nmap f) @@ -70,8 +69,9 @@ mapStates f = onGraph (nmap f) mapTransitions :: (b -> c) -> FA n a b -> FA n a c mapTransitions f = onGraph (emap f) -minimize :: NFA a -> NFA a -minimize = onGraph id +minimize :: Eq a => NFA a -> NFA a +minimize = dfa2nfa . 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 @@ -104,16 +104,49 @@ fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts) alphabet :: Eq b => Graph n a (Maybe b) -> [b] alphabet = nub . catMaybes . map getLabel . edges - -reachable :: (Eq b, Ord n) => Graph n a (Maybe b) -> n -> b -> [n] -reachable g s c = fix reachable_ [s] - where reachable_ r = r `union` [y | x <- r, es <- outf x, (_,y,l) <- es, maybe True (==c) l] - out = outgoing g - outf x = [ es | ((y,_),es) <- out, x == y ] - determinize :: Eq a => NFA a -> DFA a -determinize (FA g s f) = undefined +determinize (FA g s f) = let (ns,es) = h [start] [] [] + in FA (Graph (freshDFANodes g) [(n,()) | n <- ns] es) start (filter isDFAFinal ns) where sigma = alphabet g + out = outgoing g + start = closure out [s] + isDFAFinal n = not (null (f `intersect` n)) + freshDFANodes (Graph ns _ _) = map (:[]) ns + -- Get the new DFA states and edges produced by a set of DFA states. + new ns = unzip [ (s, (n,s,c)) | n <- ns, c <- sigma, let s = sort (reachable out c n), not (null s) ] + h currentStates oldStates oldEdges + | null currentStates = (oldStates,oldEdges) + | otherwise = h newStates' allOldStates (newEdges++oldEdges) + where (newStates,newEdges) = new currentStates + allOldStates = currentStates ++ oldStates + newStates' = nub newStates \\ allOldStates + +-- | 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 out = fix closure_ + where closure_ r = r `union` [y | x <- r, (_,y,Nothing) <- getOutgoing out x] + +-- | Get all nodes reachable from a set of nodes by one edge with the given +-- label and then any number of empty edges. +reachable :: (Eq n, Eq b) => Outgoing n a (Maybe b) -> b -> [n] -> [n] +reachable out c ns = closure out [y | n <- ns, (_,y,Just c') <- getOutgoing out n, c' == c] + +reverseNFA :: NFA a -> NFA a +reverseNFA (FA g s fs) = FA g''' s' [s] + where g' = reverseGraph g + (g'',s') = newNode () g' + g''' = newEdges [(s',f,Nothing) | f <- fs] g'' + +dfa2nfa :: DFA a -> NFA a +dfa2nfa (FA (Graph _ ns es) s fs) = FA (Graph c ns' es') s' fs' + where newNodes = zip (map fst ns) [0..] + newNode n = lookup' n newNodes + c = [length ns..] + ns' = [ (n,()) | (_,n) <- newNodes ] + es' = [ (newNode f, newNode t,Just l) | (f,t,l) <- es] + s' = newNode s + fs' = map newNode fs + -- -- * Visualization @@ -122,6 +155,9 @@ determinize (FA g s f) = undefined prFAGraphviz :: (Eq n,Show n) => FA n String String -> String prFAGraphviz = Dot.prGraphviz . toGraphviz +prFAGraphviz_ :: (Eq n,Show n,Show a, Show b) => FA n a b -> String +prFAGraphviz_ = Dot.prGraphviz . toGraphviz . mapStates show . mapTransitions show + toGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph toGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed [] (map mkNode ns) (map mkEdge es) where mkNode (n,l) = Dot.Node (show n) attrs @@ -140,6 +176,9 @@ data Graph n a b = Graph [n] [Node n a] [Edge n b] 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])] + newGraph :: [n] -> Graph n a b newGraph ns = Graph ns [] [] @@ -158,14 +197,22 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es] 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) -newEdge :: n -> n -> b -> Graph n a b -> Graph n a b -newEdge f t l (Graph c ns es) = Graph c ns ((f,t,l):es) +newEdge :: Edge n b -> Graph n a b -> Graph n a b +newEdge e (Graph c ns es) = Graph c ns (e:es) -incoming :: Ord n => Graph n a b -> [(Node n a,[Edge n b])] +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. +incoming :: Ord n => Graph n a b -> Incoming n a b incoming = groupEdgesBy getTo -outgoing :: Ord n => Graph n a b -> [(Node n a,[Edge n b])] -outgoing = groupEdgesBy getTo +-- | Get a list of all nodes and their outgoing edges. +outgoing :: Ord n => Graph n a b -> Outgoing n a b +outgoing = groupEdgesBy getFrom + +getOutgoing :: Eq n => Outgoing n a b -> n -> [Edge n b] +getOutgoing out x = head [ es | ((y,_),es) <- out, x == y ] groupEdgesBy :: (Ord n) => (Edge n b -> n) -> Graph n a b -> [(Node n a,[Edge n b])] groupEdgesBy h (Graph _ ns es) =