forked from GitHub/gf-core
187 lines
5.6 KiB
Haskell
187 lines
5.6 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : FiniteState
|
|
-- Maintainer : BB
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/09/15 18:10:44 $
|
|
-- > CVS $Author: bringert $
|
|
-- > CVS $Revision: 1.11 $
|
|
--
|
|
-- A simple finite state network module.
|
|
-----------------------------------------------------------------------------
|
|
module GF.Speech.FiniteState (FA, State, NFA, DFA,
|
|
startState, finalStates,
|
|
states, transitions,
|
|
newFA,
|
|
addFinalState,
|
|
newState, newTransition,
|
|
mapStates, mapTransitions,
|
|
moveLabelsToNodes, minimize,
|
|
prFAGraphviz) where
|
|
|
|
import GF.Data.Utilities
|
|
import Data.List
|
|
import Data.Maybe (catMaybes,fromJust)
|
|
|
|
import GF.Data.Utilities
|
|
import qualified GF.Visualization.Graphviz as Dot
|
|
|
|
type State = Int
|
|
|
|
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..])
|
|
|
|
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
|
|
|
|
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 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)
|
|
|
|
minimize :: NFA a -> NFA a
|
|
minimize = onGraph id
|
|
|
|
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 :: (Ord n,Eq a) => FA n () (Maybe a) -> FA n (Maybe a) ()
|
|
moveLabelsToNodes = onGraph moveLabelsToNodes_
|
|
where moveLabelsToNodes_ gr@(Graph c _ _) = Graph c' ns (concat ess)
|
|
where is = incoming gr
|
|
(c',is') = mapAccumL fixIncoming c is
|
|
(ns,ess) = unzip (concat is')
|
|
|
|
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
|
|
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 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
|
|
where sigma = alphabet g
|
|
|
|
--
|
|
-- * Visualization
|
|
--
|
|
|
|
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
|
|
--
|
|
|
|
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 -> [Node n a]
|
|
nodes (Graph _ ns _) = ns
|
|
|
|
edges :: Graph n a b -> [Edge n b]
|
|
edges (Graph _ _ es) = es
|
|
|
|
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 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 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)
|
|
|
|
incoming :: Ord n => Graph n a b -> [(Node n a,[Edge n b])]
|
|
incoming = groupEdgesBy getTo
|
|
|
|
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
|
|
reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
|
|
|