diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs index 21d69efa9..b0d02983a 100644 --- a/src/GF/Speech/CFGToFiniteState.hs +++ b/src/GF/Speech/CFGToFiniteState.hs @@ -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 diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs index 094806b0d..6b764cdb1 100644 --- a/src/GF/Speech/FiniteState.hs +++ b/src/GF/Speech/FiniteState.hs @@ -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 diff --git a/src/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs index 955c99d91..c23c5e384 100644 --- a/src/GF/Speech/Graph.hs +++ b/src/GF/Speech/Graph.hs @@ -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 diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs index 897113a03..ba7dea3c8 100644 --- a/src/GF/Speech/PrSLF.hs +++ b/src/GF/Speech/PrSLF.hs @@ -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)