diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Speech/CFGToFiniteState.hs | 10 | ||||
| -rw-r--r-- | src/GF/Speech/FiniteState.hs | 125 | ||||
| -rw-r--r-- | src/GF/Speech/PrSLF.hs | 6 |
3 files changed, 70 insertions, 71 deletions
diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs index 1816e4502..73765aed0 100644 --- a/src/GF/Speech/CFGToFiniteState.hs +++ b/src/GF/Speech/CFGToFiniteState.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/14 15:17:29 $ +-- > CVS $Date: 2005/09/14 16:08:35 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ +-- > CVS $Revision: 1.4 $ -- -- Approximates CFGs with finite state networks. ----------------------------------------------------------------------------- @@ -27,7 +27,7 @@ import GF.Speech.FiniteState import GF.Speech.TransformCFG cfgToFA :: Ident -- ^ Grammar name - -> Options -> CGrammar -> FA () (Maybe String) + -> Options -> CGrammar -> NFA String cfgToFA name opts = minimize . compileAutomaton start . makeSimpleRegular where start = getStartCat opts @@ -67,7 +67,7 @@ mutRecCats incAll g = equivalenceClasses $ symmetricSubrelation $ transitiveClos -- Convert a strongly regular grammar to a finite automaton. compileAutomaton :: Cat_ -- ^ Start category -> CFRules - -> FA () (Maybe Token) + -> NFA Token compileAutomaton start g = make_fa s [Cat start] f fa'' where fa = newFA () s = startState fa @@ -77,7 +77,7 @@ compileAutomaton start g = make_fa s [Cat start] f fa'' -- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\", -- Mark-Jan Nederhof. International Workshop on Parsing Technologies, 1997. make_fa :: State -> [Symbol Cat_ Token] -> State - -> FA () (Maybe Token) -> FA () (Maybe Token) + -> NFA Token -> NFA Token make_fa q0 alpha q1 fa = case alpha of [] -> newTransition q0 q1 Nothing fa diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs index 428ad8f76..d6d952aaa 100644 --- a/src/GF/Speech/FiniteState.hs +++ b/src/GF/Speech/FiniteState.hs @@ -5,13 +5,13 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/14 15:29:53 $ +-- > CVS $Date: 2005/09/14 16:08:35 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ +-- > CVS $Revision: 1.9 $ -- -- A simple finite state network module. ----------------------------------------------------------------------------- -module GF.Speech.FiniteState (FA, State, +module GF.Speech.FiniteState (FA, State, NFA, DFA, startState, finalStates, states, transitions, newFA, @@ -22,71 +22,106 @@ module GF.Speech.FiniteState (FA, State, prFAGraphviz) where import Data.List -import Data.Maybe (fromJust) +import Data.Maybe (catMaybes,fromJust) import GF.Data.Utilities import qualified GF.Visualization.Graphviz as Dot +type State = Int -data FA a b = FA (Graph State a b) State [State] +data FA n a b = FA (Graph n a b) n [n] -type State = Node +type NFA a = FA State () (Maybe a) -startState :: FA a b -> State +type DFA a = FA [State] () a + + +startState :: FA n a b -> n startState (FA _ s _) = s -finalStates :: FA a b -> [State] +finalStates :: FA n a b -> [n] finalStates (FA _ _ ss) = ss -states :: FA a b -> [(State,a)] +states :: FA n a b -> [(n,a)] states (FA g _ _) = nodes g -transitions :: FA a b -> [(State,State,b)] +transitions :: FA n a b -> [(n,n,b)] transitions (FA g _ _) = edges g -newFA :: a -- ^ Start node label - -> FA a b +newFA :: Enum n => a -- ^ Start node label + -> FA n a b newFA l = FA g s [] - where (g,s) = newNode l (newGraph [0..]) + where (g,s) = newNode l (newGraph [toEnum 0..]) -addFinalState :: State -> FA a b -> FA a b +addFinalState :: n -> FA n a b -> FA n a b addFinalState f (FA g s ss) = FA g s (f:ss) -newState :: a -> FA a b -> (FA a b, State) +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 -newTransition :: State -> State -> b -> FA a b -> FA a b +newTransition :: n -> n -> b -> FA n a b -> FA n a b newTransition f t l = onGraph (newEdge f t l) -mapStates :: (a -> c) -> FA a b -> FA c b +mapStates :: (a -> c) -> FA n a b -> FA n c b mapStates f = onGraph (nmap f) -mapTransitions :: (b -> c) -> FA a b -> FA a c +mapTransitions :: (b -> c) -> FA n a b -> FA n a c mapTransitions f = onGraph (emap f) -minimize :: FA () (Maybe a) -> FA () (Maybe a) -minimize = onGraph mimimizeGr1 +minimize :: NFA a -> NFA a +minimize = onGraph id -onGraph :: (Graph State a b -> Graph State c d) -> FA a b -> FA c d +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 -- | 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 :: Eq a => FA () (Maybe a) -> FA (Maybe a) () +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 is = incoming gr + (c',is') = mapAccumL fixIncoming c is + (ns,ls,ess) = unzip3 (concat is') -prFAGraphviz :: FA String String -> String -prFAGraphviz = Dot.prGraphviz . mkGraphviz - where - mkGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed [] (map mkNode ns) (map mkEdge es) +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 + (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 = [ (x, l, to x l) | (x,l) <- 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 +determinize (FA g s f) = undefined + + +prFAGraphviz :: (Eq n,Show n) => FA n String String -> String +prFAGraphviz = Dot.prGraphviz . toGraphviz + +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 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)] + -- -- * Graphs -- @@ -94,8 +129,6 @@ prFAGraphviz = Dot.prGraphviz . mkGraphviz data Graph n a b = Graph [n] [(n,a)] [(n,n,b)] deriving (Eq,Show) -type Node = Int - newGraph :: [n] -> Graph n a b newGraph ns = Graph ns [] [] @@ -124,43 +157,9 @@ incoming (Graph _ ns es) = snd $ mapAccumL f (sortBy compareDest es) (sortBy com 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_ :: (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 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 - (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 = [ (x, l, to x l) | (x,l) <- newNodes ] - getLabel :: (n,n,b) -> b getLabel (_,_,l) = l -mimimizeGr1 :: Eq n => Graph n () (Maybe a) -> Graph n () (Maybe a) -mimimizeGr1 = removeEmptyLoops1 - -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 n (Maybe a) () -> Graph n (Maybe a) () -mimimizeGr2 = id - -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 n a b -> Graph n a b reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ] + diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs index fac25ed77..33ddf03ca 100644 --- a/src/GF/Speech/PrSLF.hs +++ b/src/GF/Speech/PrSLF.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/14 15:17:30 $ +-- > CVS $Date: 2005/09/14 16:08:35 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.9 $ +-- > CVS $Revision: 1.10 $ -- -- This module converts a CFG to an SLF finite-state network -- for use with the ATK recognizer. The SLF format is described @@ -71,7 +71,7 @@ regularPrinter = prCFRules . makeSimpleRegular join g = concat . intersperse g showRhs = unwords . map (symbol id show) -automatonToSLF :: FA (Maybe String) () -> SLF +automatonToSLF :: FA State (Maybe String) () -> SLF automatonToSLF fa = SLF { slfNodes = map mkSLFNode (states fa), slfEdges = zipWith mkSLFEdge [0..] (transitions fa) } |