mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-08 18:52:50 -06:00
decd7122de
+ References to modules under src/compiler have been eliminated from the PGF library (under src/runtime/haskell). Only two functions had to be moved (from GF.Data.Utilities to PGF.Utilities) to make this possible, other apparent dependencies turned out to be vacuous. + In gf.cabal, the GF executable no longer directly depends on the PGF library source directory, but only on the exposed library modules. This means that there is less duplication in gf.cabal and that the 30 modules in the PGF library will no longer be compiled twice while building GF. To make this possible, additional PGF library modules have been exposed, even though they should probably be considered for internal use only. They could be collected in a PGF.Internal module, or marked as "unstable", to make this explicit. + Also, by using the -fwarn-unused-imports flag, ~220 redundant imports were found and removed, reducing the total number of imports by ~15%.
330 lines
12 KiB
Haskell
330 lines
12 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- 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
|