---------------------------------------------------------------------- -- | -- Module : FiniteState -- Maintainer : BB -- Stability : (stable) -- Portability : (portable) -- -- > CVS $Date: 2005/11/10 16:43:44 $ -- > CVS $Author: bringert $ -- > CVS $Revision: 1.16 $ -- -- A simple finite state network module. ----------------------------------------------------------------------------- module GF.Speech.FiniteState (FA(..), State, NFA, DFA, startState, finalStates, states, transitions, isInternal, newFA, newFA_, addFinalState, newState, newStates, newTransition, newTransitions, insertTransitionWith, insertTransitionsWith, mapStates, mapTransitions, modifyTransitions, nonLoopTransitionsTo, nonLoopTransitionsFrom, loops, removeState, oneFinalState, insertNFA, onGraph, moveLabelsToNodes, removeTrivialEmptyNodes, minimize, dfa2nfa, unusedNames, renameStates, prFAGraphviz, faToGraphviz) where import Data.List import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import GF.Data.Utilities import GF.Data.Graph import qualified GF.Data.Graphviz as Dot type State = Int -- | Type parameters: node id type, state label type, edge label type -- Data constructor arguments: nodes and edges, start state, final states data FA n a b = FA !(Graph n a b) !n ![n] type NFA a = FA State () (Maybe a) type DFA a = FA State () a startState :: FA n a b -> n startState (FA _ s _) = s finalStates :: FA n a b -> [n] finalStates (FA _ _ ss) = ss states :: FA n a b -> [(n,a)] states (FA g _ _) = nodes g transitions :: FA n a b -> [(n,n,b)] transitions (FA g _ _) = edges g newFA :: Enum n => a -- ^ Start node label -> FA n a b newFA l = FA g s [] where (g,s) = newNode l (newGraph [toEnum 0..]) -- | Create a new finite automaton with an initial and a final state. newFA_ :: Enum n => (FA n () b, n, n) newFA_ = (fa'', s, f) where fa = newFA () s = startState fa (fa',f) = newState () fa fa'' = addFinalState f fa' addFinalState :: n -> FA n a b -> FA n a b addFinalState f (FA g s ss) = FA g s (f:ss) newState :: a -> FA n a b -> (FA n a b, n) newState x (FA g s ss) = (FA g' s ss, n) where (g',n) = newNode x g newStates :: [a] -> FA n a b -> (FA n a b, [(n,a)]) newStates xs (FA g s ss) = (FA g' s ss, ns) where (g',ns) = newNodes xs g newTransition :: n -> n -> b -> FA n a b -> FA n a b newTransition f t l = onGraph (newEdge (f,t,l)) newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b newTransitions es = onGraph (newEdges es) insertTransitionWith :: Eq n => (b -> b -> b) -> (n, n, b) -> FA n a b -> FA n a b insertTransitionWith f t = onGraph (insertEdgeWith f t) insertTransitionsWith :: Eq n => (b -> b -> b) -> [(n, n, b)] -> FA n a b -> FA n a b insertTransitionsWith f ts fa = foldl' (flip (insertTransitionWith f)) fa ts mapStates :: (a -> c) -> FA n a b -> FA n c b mapStates f = onGraph (nmap f) mapTransitions :: (b -> c) -> FA n a b -> FA n a c mapTransitions f = onGraph (emap f) modifyTransitions :: ([(n,n,b)] -> [(n,n,b)]) -> FA n a b -> FA n a b modifyTransitions f = onGraph (\ (Graph r ns es) -> Graph r ns (f es)) removeState :: Ord n => n -> FA n a b -> FA n a b removeState n = onGraph (removeNode n) minimize :: Ord a => NFA a -> DFA a minimize = determinize . reverseNFA . dfa2nfa . determinize . reverseNFA unusedNames :: FA n a b -> [n] unusedNames (FA (Graph names _ _) _ _) = names -- | Gets all incoming transitions to a given state, excluding -- transtions from the state itself. nonLoopTransitionsTo :: Eq n => n -> FA n a b -> [(n,b)] nonLoopTransitionsTo s fa = [(f,l) | (f,t,l) <- transitions fa, t == s && f /= s] nonLoopTransitionsFrom :: Eq n => n -> FA n a b -> [(n,b)] nonLoopTransitionsFrom s fa = [(t,l) | (f,t,l) <- transitions fa, f == s && t /= s] loops :: Eq n => n -> FA n a b -> [b] loops s fa = [l | (f,t,l) <- transitions fa, f == s && t == s] -- | Give new names to all nodes. renameStates :: Ord x => [y] -- ^ Infinite supply of new names -> FA x a b -> FA y a b renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs' where (ns,rest) = splitAt (length (nodes g)) supply newNodes = Map.fromList (zip (map fst (nodes g)) ns) newName n = Map.findWithDefault (error "FiniteState.newName") n newNodes s' = newName s fs' = map newName fs -- | Insert an NFA into another insertNFA :: NFA a -- ^ NFA to insert into -> (State, State) -- ^ States to insert between -> NFA a -- ^ NFA to insert. -> NFA a insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2) = FA (newEdges es g') s1 fs1 where es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2] (g',ren) = mergeGraphs g1 g2 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. oneFinalState :: a -- ^ Label to give the new node -> b -- ^ Label to give the new edges -> FA n a b -- ^ The old network -> FA n a b -- ^ The new network oneFinalState nl el fa = let (FA g s fs,nf) = newState nl fa es = [ (f,nf,el) | f <- fs ] in FA (newEdges es g) s [nf] -- | Transform a standard finite automaton with labelled edges -- to one where the labels are on the nodes instead. This can add -- up to one extra node per edge. moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) () moveLabelsToNodes = onGraph f where f g@(Graph c _ _) = Graph c' ns (concat ess) where is = [ ((n,l),inc) | (n, (l,inc,_)) <- Map.toList (nodeInfo g)] (c',is') = mapAccumL fixIncoming c is (ns,ess) = unzip (concat is') -- | Remove empty nodes which are not start or final, and have -- exactly one outgoing edge or exactly one incoming edge. removeTrivialEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) () removeTrivialEmptyNodes = pruneUnusable . skipSimpleEmptyNodes -- | Move edges to empty nodes to point to the next node(s). -- This is not done if the pointed-to node is a final node. skipSimpleEmptyNodes :: (Eq a, Ord n) => FA n (Maybe a) () -> FA n (Maybe a) () skipSimpleEmptyNodes fa = onGraph og fa where og g@(Graph c ns es) = if es' == es then g else og (Graph c ns es') where es' = concatMap changeEdge es info = nodeInfo g changeEdge e@(f,t,()) | isNothing (getNodeLabel info t) -- && (i * o <= i + o) && not (isFinal fa t) = [ (f,t',()) | (_,t',()) <- getOutgoing info t] | otherwise = [e] -- where i = inDegree info t -- o = outDegree info t isInternal :: Eq n => FA n a b -> n -> Bool isInternal (FA _ start final) n = n /= start && n `notElem` final isFinal :: Eq n => FA n a b -> n -> Bool isFinal (FA _ _ final) n = n `elem` final -- | Remove all internal nodes with no incoming edges -- or no outgoing edges. pruneUnusable :: Ord n => FA n (Maybe a) () -> FA n (Maybe a) () pruneUnusable fa = onGraph f fa where f g = if Set.null rns then g else f (removeNodes rns g) where info = nodeInfo g rns = Set.fromList [ n | (n,_) <- nodes g, isInternal fa n, inDegree info n == 0 || outDegree info n == 0] fixIncoming :: (Ord n, Eq a) => [n] -> (Node n (),[Edge n (Maybe a)]) -- ^ A node and its incoming edges -> ([n],[(Node n (Maybe a),[Edge n ()])]) -- ^ Replacement nodes with their -- incoming edges. fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts) where ls = nub $ map edgeLabel es (cs',cs'') = splitAt (length ls) cs newNodes = zip cs' ls es' = [ (x,n,()) | x <- map fst newNodes ] -- separate cyclic and non-cyclic edges (cyc,ncyc) = partition (\ (f,_,_) -> f == n) es -- keep all incoming non-cyclic edges with the right label to (x,l) = [ (f,x,()) | (f,_,l') <- ncyc, l == l'] -- for each cyclic edge with the right label, -- add an edge from each of the new nodes (including this one) ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes] newContexts = [ (v, to v) | v <- newNodes ] alphabet :: Eq b => Graph n a (Maybe b) -> [b] alphabet = nub . catMaybes . map edgeLabel . edges determinize :: Ord a => NFA a -> DFA a 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 renameStates [0..] fa where info = nodeInfo g -- reach = nodesReachable out start = closure info $ Set.singleton s isDFAFinal n = not (Set.null (Set.fromList f `Set.intersection` n)) h currentStates oldStates es | Set.null currentStates = (oldStates,es) | otherwise = ((h $! uniqueNewStates) $! allOldStates) $! es' where 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 info n --reachable reach n rs' = rs `Set.union` Set.fromList (map snd cs) es' = es `Set.union` Set.fromList [(n,s,c) | (c,s) <- cs] -- | Get all the nodes reachable from a list of nodes by only empty edges. closure :: Ord n => NodeInfo n a (Maybe b) -> Set n -> Set n closure info x = closure_ x x where closure_ acc check | Set.null check = acc | otherwise = closure_ acc' check' where reach = Set.fromList [y | x <- Set.toList check, (_,y,Nothing) <- getOutgoing info x] acc' = acc `Set.union` reach check' = reach Set.\\ 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) => NodeInfo n a (Maybe b) -> Set n -> [(b,Set n)] reachable info ns = Map.toList $ Map.map (closure info . Set.fromList) $ reachable1 info ns reachable1 info ns = Map.fromListWith (++) [(c, [y]) | n <- Set.toList ns, (_,y,Just c) <- getOutgoing info n] 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 = mapTransitions Just -- -- * Visualization -- prFAGraphviz :: (Eq n,Show n) => FA n String String -> String prFAGraphviz = Dot.prGraphviz . faToGraphviz prFAGraphviz_ :: (Eq n,Show n,Show a, Show b) => FA n a b -> String prFAGraphviz_ = Dot.prGraphviz . faToGraphviz . mapStates show . mapTransitions show faToGraphviz :: (Eq n,Show n) => FA n String String -> Dot.Graph faToGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed Nothing [] (map mkNode ns) (map mkEdge es) [] where mkNode (n,l) = Dot.Node (show n) attrs where attrs = [("label",l)] ++ if n == s then [("shape","box")] else [] ++ if n `elem` f then [("style","bold")] else [] mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)] -- -- * Utilities -- lookups :: Ord k => [k] -> Map k a -> [a] lookups xs m = mapMaybe (flip Map.lookup m) xs