mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-27 21:42:50 -06:00
remove all files that aren't used in GF-3.0
This commit is contained in:
kr.angelov
@@ -1,329 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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.Speech.Graph
|
||||
import qualified GF.Visualization.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
|
||||
Reference in New Issue
Block a user