Generate monolithic FAs by expanding an MFA.

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

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
 

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

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)