forked from GitHub/gf-core
Generate monolithic FAs by expanding an MFA.
This commit is contained in:
bringert
@@ -13,7 +13,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Speech.CFGToFiniteState (cfgToFA, makeSimpleRegular,
|
||||
MFALabel(..), MFA(..), cfgToMFA) where
|
||||
MFALabel(..), MFA(..), cfgToMFA,cfgToFA') where
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
@@ -30,6 +30,7 @@ import GF.Infra.Ident (Ident)
|
||||
import GF.Infra.Option (Options)
|
||||
|
||||
import GF.Speech.FiniteState
|
||||
import GF.Speech.Graph
|
||||
import GF.Speech.Relation
|
||||
import GF.Speech.TransformCFG
|
||||
|
||||
@@ -45,6 +46,17 @@ data MutRecSet = MutRecSet {
|
||||
|
||||
type MutRecSets = Map Cat_ MutRecSet
|
||||
|
||||
--
|
||||
-- * Multiple DFA type
|
||||
--
|
||||
|
||||
data MFALabel a = MFASym a | MFASub String
|
||||
deriving Eq
|
||||
|
||||
data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))]
|
||||
|
||||
|
||||
|
||||
cfgToFA :: Options -> CGrammar -> DFA String
|
||||
cfgToFA opts = minimize . compileAutomaton start . makeSimpleRegular
|
||||
where start = getStartCat opts
|
||||
@@ -139,24 +151,22 @@ make_fa c@(g,ns) q0 alpha q1 fa =
|
||||
make_fa_ = make_fa c
|
||||
make_fas xs fa = foldl' (\f' (s1,xs,s2) -> make_fa_ s1 xs s2 f') fa xs
|
||||
|
||||
|
||||
--
|
||||
-- * Multiple DFA type
|
||||
--
|
||||
|
||||
data MFALabel a = MFASym a | MFASub String
|
||||
deriving Eq
|
||||
|
||||
data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))]
|
||||
|
||||
--
|
||||
-- * Compile a strongly regular grammar to a DFA with sub-automata
|
||||
--
|
||||
|
||||
cfgToMFA :: Options -> CGrammar -> MFA String
|
||||
cfgToMFA opts g = sortSubLats $ removeUnusedSubLats mfa
|
||||
cfgToMFA opts g = buildMFA start g
|
||||
where start = getStartCat opts
|
||||
startFA = let (fa,s,f) = newFA_
|
||||
|
||||
-- | Build a DFA by building and expanding an MFA
|
||||
cfgToFA' :: Options -> CGrammar -> DFA String
|
||||
cfgToFA' opts g = mfaToDFA $ cfgToMFA opts g
|
||||
|
||||
buildMFA :: Cat_ -- ^ Start category
|
||||
-> CGrammar -> MFA String
|
||||
buildMFA start g = sortSubLats $ removeUnusedSubLats mfa
|
||||
where startFA = let (fa,s,f) = newFA_
|
||||
in newTransition s f (MFASub start) fa
|
||||
fas = compileAutomata $ makeSimpleRegular g
|
||||
mkMFALabel (Cat c) = MFASub c
|
||||
@@ -164,6 +174,19 @@ cfgToMFA opts g = sortSubLats $ removeUnusedSubLats mfa
|
||||
toMFA = mapTransitions mkMFALabel
|
||||
mfa = MFA startFA [(c, toMFA (minimize fa)) | (c,fa) <- fas]
|
||||
|
||||
mfaToDFA :: Ord a => MFA a -> DFA a
|
||||
mfaToDFA (MFA main subs) = minimize $ expand $ dfa2nfa main
|
||||
where
|
||||
subs' = Map.fromList [(c, dfa2nfa n) | (c,n) <- subs]
|
||||
getSub l = fromJust $ Map.lookup l subs'
|
||||
expand (FA (Graph c ns es) s f)
|
||||
= foldl' expandEdge (FA (Graph c ns []) s f) es
|
||||
expandEdge fa (f,t,x) =
|
||||
case x of
|
||||
Nothing -> newTransition f t Nothing fa
|
||||
Just (MFASym s) -> newTransition f t (Just s) fa
|
||||
Just (MFASub l) -> insertNFA fa (f,t) (expand $ getSub l)
|
||||
|
||||
removeUnusedSubLats :: MFA a -> MFA a
|
||||
removeUnusedSubLats mfa@(MFA main subs) = MFA main [(c,s) | (c,s) <- subs, isUsed c]
|
||||
where
|
||||
|
||||
@@ -11,15 +11,17 @@
|
||||
--
|
||||
-- A simple finite state network module.
|
||||
-----------------------------------------------------------------------------
|
||||
module GF.Speech.FiniteState (FA, State, NFA, DFA,
|
||||
module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
|
||||
startState, finalStates,
|
||||
states, transitions,
|
||||
newFA,
|
||||
addFinalState,
|
||||
newState, newStates,
|
||||
newTransition,
|
||||
newTransition, newTransitions,
|
||||
mapStates, mapTransitions,
|
||||
oneFinalState,
|
||||
insertNFA,
|
||||
onGraph,
|
||||
moveLabelsToNodes, removeTrivialEmptyNodes,
|
||||
minimize,
|
||||
dfa2nfa,
|
||||
@@ -77,6 +79,9 @@ newStates xs (FA g s ss) = (FA g' s ss, ns)
|
||||
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)
|
||||
|
||||
mapStates :: (a -> c) -> FA n a b -> FA n c b
|
||||
mapStates f = onGraph (nmap f)
|
||||
|
||||
@@ -100,6 +105,17 @@ renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
|
||||
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
|
||||
|
||||
|
||||
@@ -20,7 +20,7 @@ module GF.Speech.Graph ( Graph(..), Node, Edge, NodeInfo
|
||||
, inDegree, outDegree
|
||||
, nodeLabel
|
||||
, edgeFrom, edgeTo, edgeLabel
|
||||
, reverseGraph, renameNodes
|
||||
, reverseGraph, mergeGraphs, renameNodes
|
||||
) where
|
||||
|
||||
import GF.Data.Utilities
|
||||
@@ -120,36 +120,6 @@ outDegree i n = length $ getOutgoing i n
|
||||
getNodeLabel :: Ord n => NodeInfo n a b -> n -> a
|
||||
getNodeLabel i n = let (l,_,_) = lookupNode i n in l
|
||||
|
||||
{-
|
||||
-- | Get a map of nodes and their incoming edges.
|
||||
incoming :: Ord n => Graph n a b -> Incoming n a b
|
||||
incoming = groupEdgesBy getTo
|
||||
|
||||
-- | Get all edges ending at a given node.
|
||||
getIncoming :: Ord n => Incoming n a b -> n -> [Edge n b]
|
||||
getIncoming out x = maybe [] snd (Map.lookup x out)
|
||||
|
||||
incomingToList :: Incoming n a b -> [(Node n a, [Edge n b])]
|
||||
incomingToList out = [ ((n,x),es) | (n,(x,es)) <- Map.toList out ]
|
||||
|
||||
-- | Get a map of nodes and their outgoing edges.
|
||||
outgoing :: Ord n => Graph n a b -> Outgoing n a b
|
||||
outgoing = groupEdgesBy getFrom
|
||||
|
||||
-- | Get all edges starting at a given node.
|
||||
getOutgoing :: Ord n => Outgoing n a b -> n -> [Edge n b]
|
||||
getOutgoing out x = maybe [] snd (Map.lookup x out)
|
||||
|
||||
-- | Get the label of a node given its outgoing list.
|
||||
getLabelOut :: Ord n => Outgoing n a b -> n -> a
|
||||
getLabelOut out x = fst $ fromJust (Map.lookup x out)
|
||||
|
||||
groupEdgesBy :: (Ord n) => (Edge n b -> n) -> Graph n a b -> Map n (a,[Edge n b])
|
||||
groupEdgesBy f (Graph _ ns es) =
|
||||
foldl' (\m e -> Map.adjust (\ (x,el) -> (x,e:el)) (f e) m) nm es
|
||||
where nm = Map.fromList [ (n, (x,[])) | (n,x) <- ns ]
|
||||
-}
|
||||
|
||||
nodeLabel :: Node n a -> a
|
||||
nodeLabel = snd
|
||||
|
||||
@@ -165,6 +135,21 @@ edgeLabel (_,_,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 ]
|
||||
|
||||
-- | Add the nodes from the second graph to the first graph.
|
||||
-- The nodes in the second graph will be renamed using the name
|
||||
-- supply in the first graph.
|
||||
-- This function is more efficient when the second graph
|
||||
-- is smaller than the first.
|
||||
mergeGraphs :: Ord m => Graph n a b -> Graph m a b
|
||||
-> (Graph n a b, m -> n) -- ^ The new graph and a function translating
|
||||
-- the old names of nodes in the second graph
|
||||
-- to names in the new graph.
|
||||
mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
|
||||
where
|
||||
(xs,c') = splitAt (length (nodes g2)) c
|
||||
newNames = Map.fromList (zip (map fst (nodes g2)) xs)
|
||||
newName n = fromJust $ Map.lookup n newNames
|
||||
Graph _ ns2 es2 = renameNodes newName undefined g2
|
||||
|
||||
-- | Rename the nodes in the graph.
|
||||
renameNodes :: (n -> m) -- ^ renaming function
|
||||
|
||||
@@ -78,7 +78,7 @@ renameSubs (MFA main subs) = MFA (renameLabels main) subs'
|
||||
|
||||
slfGraphvizPrinter :: Ident -> Options -> CGrammar -> String
|
||||
slfGraphvizPrinter name opts cfg
|
||||
= prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA opts cfg
|
||||
= prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' opts cfg
|
||||
where
|
||||
gvFA = mapStates (fromMaybe "") . mapTransitions (const "")
|
||||
|
||||
@@ -116,7 +116,7 @@ gvSLFFA n fa =
|
||||
|
||||
slfPrinter :: Ident -> Options -> CGrammar -> String
|
||||
slfPrinter name opts cfg
|
||||
= prSLF (automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA opts cfg) ""
|
||||
= prSLF (automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' opts cfg) ""
|
||||
|
||||
--
|
||||
-- * SLF printing (with sub-networks)
|
||||
|
||||
Reference in New Issue
Block a user