diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs index 374732426..428ad8f76 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/14 15:17:29 $ +-- > CVS $Date: 2005/09/14 15:29:53 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ +-- > CVS $Revision: 1.8 $ -- -- A simple finite state network module. ----------------------------------------------------------------------------- @@ -28,7 +28,7 @@ import GF.Data.Utilities import qualified GF.Visualization.Graphviz as Dot -data FA a b = FA (Graph a b) State [State] +data FA a b = FA (Graph State a b) State [State] type State = Node @@ -47,16 +47,16 @@ transitions (FA g _ _) = edges g newFA :: a -- ^ Start node label -> FA a b newFA l = FA g s [] - where (g,s) = newNode l newGraph + where (g,s) = newNode l (newGraph [0..]) -addFinalState :: Node -> FA a b -> FA a b +addFinalState :: State -> FA a b -> FA a b addFinalState f (FA g s ss) = FA g s (f:ss) newState :: a -> FA a b -> (FA a b, State) newState x (FA g s ss) = (FA g' s ss, n) where (g',n) = newNode x g -newTransition :: Node -> Node -> b -> FA a b -> FA a b +newTransition :: State -> State -> b -> FA a b -> FA a b newTransition f t l = onGraph (newEdge f t l) mapStates :: (a -> c) -> FA a b -> FA c b @@ -65,12 +65,12 @@ mapStates f = onGraph (nmap f) mapTransitions :: (b -> c) -> FA a b -> FA a c mapTransitions f = onGraph (emap f) -asGraph :: FA a b -> Graph a b -asGraph (FA g _ _) = g - minimize :: FA () (Maybe a) -> FA () (Maybe a) minimize = onGraph mimimizeGr1 +onGraph :: (Graph State a b -> Graph State c d) -> FA a b -> FA c d +onGraph f (FA g s ss) = FA (f g) s ss + -- | 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. @@ -90,57 +90,51 @@ prFAGraphviz = Dot.prGraphviz . mkGraphviz -- -- * Graphs -- -type Node = Int -data Graph a b = Graph Node [(Node,a)] [(Node,Node,b)] +data Graph n a b = Graph [n] [(n,a)] [(n,n,b)] deriving (Eq,Show) -onGraph :: (Graph a b -> Graph c d) -> FA a b -> FA c d -onGraph f (FA g s ss) = FA (f g) s ss +type Node = Int --- graphToFA :: State -> [State] -> Graph a b -> FA a b --- graphToFA s fs (Graph _ ss ts) = buildFA s fs ss ts +newGraph :: [n] -> Graph n a b +newGraph ns = Graph ns [] [] -newGraph :: Graph a b -newGraph = Graph 0 [] [] - -nodes :: Graph a b -> [(Node,a)] +nodes :: Graph n a b -> [(n,a)] nodes (Graph _ ns _) = ns -edges :: Graph a b -> [(Node,Node,b)] +edges :: Graph n a b -> [(n,n,b)] edges (Graph _ _ es) = es -nmap :: (a -> c) -> Graph a b -> Graph 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 -emap :: (b -> c) -> Graph a b -> Graph a c +emap :: (b -> c) -> Graph n a b -> Graph n a c emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es] -newNode :: a -> Graph a b -> (Graph a b,State) -newNode l (Graph c ns es) = (Graph s ((s,l):ns) es, s) - where s = c+1 +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 :: State -> State -> b -> Graph a b -> Graph a b +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) -incoming :: Graph a b -> [(Node,a,[(Node,Node,b)])] +incoming :: Ord n => Graph n a b -> [(n,a,[(n,n,b)])] incoming (Graph _ ns es) = snd $ mapAccumL f (sortBy compareDest es) (sortBy compareFst ns) where destIs d (_,t,_) = t == d compareDest (_,t1,_) (_,t2,_) = compare t1 t2 compareFst p1 p2 = compare (fst p1) (fst p2) f es' (n,l) = let (nes,es'') = span (destIs n) es' in (es'',(n,l,nes)) -moveLabelsToNodes_ :: Eq a => Graph () (Maybe a) -> Graph (Maybe a) () +moveLabelsToNodes_ :: (Ord n, Eq a) => Graph n () (Maybe a) -> Graph n (Maybe a) () moveLabelsToNodes_ gr@(Graph c _ _) = mimimizeGr2 $ Graph c' (zip ns ls) (concat ess) where is = incoming gr (c',is') = mapAccumL fixIncoming c is (ns,ls,ess) = unzip3 (concat is') -fixIncoming :: Eq a => Node -> (Node,(),[(Node,Node,Maybe a)]) -> (Node,[(Node,Maybe a,[(Node,Node,())])]) -fixIncoming next c@(n,(),es) = (next', (n,Nothing,es'):newContexts) +fixIncoming :: (Eq n, Eq a) => [n] -> (n,(),[(n,n,Maybe a)]) -> ([n],[(n,Maybe a,[(n,n,())])]) +fixIncoming cs c@(n,(),es) = (cs'', (n,Nothing,es'):newContexts) where ls = nub $ map getLabel es - next' = next + length ls - newNodes = zip [next..next'-1] ls + (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 @@ -151,22 +145,22 @@ fixIncoming next c@(n,(),es) = (next', (n,Nothing,es'):newContexts) ++ [ (y,x,()) | (f,_,l') <- cyc, l == l', (y,_) <- newNodes] newContexts = [ (x, l, to x l) | (x,l) <- newNodes ] -getLabel :: (Node,Node,b) -> b +getLabel :: (n,n,b) -> b getLabel (_,_,l) = l -mimimizeGr1 :: Graph () (Maybe a) -> Graph () (Maybe a) +mimimizeGr1 :: Eq n => Graph n () (Maybe a) -> Graph n () (Maybe a) mimimizeGr1 = removeEmptyLoops1 -removeEmptyLoops1 :: Graph () (Maybe a) -> Graph () (Maybe a) +removeEmptyLoops1 :: Eq n => Graph n () (Maybe a) -> Graph n () (Maybe a) removeEmptyLoops1 (Graph c ns es) = Graph c ns (filter (not . isEmptyLoop) es) where isEmptyLoop (f,t,Nothing) | f == t = True isEmptyLoop _ = False -mimimizeGr2 :: Graph (Maybe a) () -> Graph (Maybe a) () +mimimizeGr2 :: Graph n (Maybe a) () -> Graph n (Maybe a) () mimimizeGr2 = id -removeDuplicateEdges :: Ord b => Graph a b -> Graph a b -removeDuplicateEdges (Graph c ns es) = Graph c ns (sortNub es) +removeDuplicateEdges :: (Eq n, Ord b) => Graph n a b -> Graph n a b +removeDuplicateEdges (Graph c ns es) = Graph c ns (nub es) -reverseGraph :: Graph a b -> Graph a b +reverseGraph :: Graph n a b -> Graph n a b reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]