diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs index f32e43af3..7bc5040fd 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 15:17:29 $ +-- > CVS $Date: 2005/09/14 18:00:19 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ +-- > CVS $Revision: 1.4 $ -- -- Basic functions not in the standard libraries ----------------------------------------------------------------------------- @@ -85,6 +85,14 @@ unionAll = nub . concat lookup' :: Eq a => a -> [(a,b)] -> b lookup' x = fromJust . lookup x +-- * ordering functions + +compareBy :: Ord b => (a -> b) -> a -> a -> Ordering +compareBy f = both f compare + +both :: (a -> b) -> (b -> b -> c) -> a -> a -> c +both f g x y = g (f x) (f y) + -- * functions on pairs mapFst :: (a -> a') -> (a, b) -> (a', b) diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs index d6d952aaa..a57328a03 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 16:08:35 $ +-- > CVS $Date: 2005/09/14 18:00:19 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.9 $ +-- > CVS $Revision: 1.10 $ -- -- A simple finite state network module. ----------------------------------------------------------------------------- @@ -21,6 +21,7 @@ module GF.Speech.FiniteState (FA, State, NFA, DFA, moveLabelsToNodes, minimize, prFAGraphviz) where +import GF.Data.Utilities import Data.List import Data.Maybe (catMaybes,fromJust) @@ -80,13 +81,13 @@ onGraph f (FA g s ss) = FA (f g) s ss -- up to one extra node per edge. moveLabelsToNodes :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) () moveLabelsToNodes = onGraph moveLabelsToNodes_ - where moveLabelsToNodes_ gr@(Graph c _ _) = Graph c' (zip ns ls) (concat ess) + where moveLabelsToNodes_ gr@(Graph c _ _) = Graph c' ns (concat ess) where is = incoming gr (c',is') = mapAccumL fixIncoming c is - (ns,ls,ess) = unzip3 (concat is') + (ns,ess) = unzip (concat is') -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) +fixIncoming :: (Eq n, Eq a) => [n] -> (Node n (),[Edge n (Maybe a)]) -> ([n],[(Node n (Maybe a),[Edge n ()])]) +fixIncoming cs c@((n,()),es) = (cs'', ((n,Nothing),es'):newContexts) where ls = nub $ map getLabel es (cs',cs'') = splitAt (length ls) cs newNodes = zip cs' ls @@ -94,21 +95,29 @@ fixIncoming cs c@(n,(),es) = (cs'', (n,Nothing,es'):newContexts) -- 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 = [ (x, l, to x l) | (x,l) <- newNodes ] + 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 getLabel . edges -reachable :: (Eq b, Eq n) => Graph n a (Maybe b) -> n -> b -> [n] -reachable = undefined -determinize :: NFA a -> DFA a +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 + where sigma = alphabet g +-- +-- * Visualization +-- prFAGraphviz :: (Eq n,Show n) => FA n String String -> String prFAGraphviz = Dot.prGraphviz . toGraphviz @@ -126,16 +135,19 @@ toGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed [] (map mkNode ns) -- * Graphs -- -data Graph n a b = Graph [n] [(n,a)] [(n,n,b)] +data Graph n a b = Graph [n] [Node n a] [Edge n b] deriving (Eq,Show) +type Node n a = (n,a) +type Edge n b = (n,n,b) + newGraph :: [n] -> Graph n a b newGraph ns = Graph ns [] [] -nodes :: Graph n a b -> [(n,a)] +nodes :: Graph n a b -> [Node n a] nodes (Graph _ ns _) = ns -edges :: Graph n a b -> [(n,n,b)] +edges :: Graph n a b -> [Edge n b] edges (Graph _ _ es) = es nmap :: (a -> c) -> Graph n a b -> Graph n c b @@ -150,14 +162,24 @@ 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) -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)) +incoming :: Ord n => Graph n a b -> [(Node n a,[Edge n b])] +incoming = groupEdgesBy getTo -getLabel :: (n,n,b) -> b +outgoing :: Ord n => Graph n a b -> [(Node n a,[Edge n b])] +outgoing = groupEdgesBy getTo + +groupEdgesBy :: (Ord n) => (Edge n b -> n) -> Graph n a b -> [(Node n a,[Edge n b])] +groupEdgesBy h (Graph _ ns es) = + snd $ mapAccumL f (sortBy (compareBy h) es) (sortBy (compareBy fst) ns) + where f es' v@(n,_) = let (nes,es'') = span ((==n) . h) es' in (es'',(v,nes)) + +getFrom :: Edge n b -> n +getFrom (f,_,_) = f + +getTo :: Edge n b -> n +getTo (_,t,_) = t + +getLabel :: Edge n b -> b getLabel (_,_,l) = l reverseGraph :: Graph n a b -> Graph n a b