Some clean-up in finite-state network generation: MFA now keeps track of start lattice name, instead of having a wrapper lattice. Replaced MFALabel with Symbol.

src/GF/Speech/CFGToFiniteState.hs

@@ -13,7 +13,7 @@
 -----------------------------------------------------------------------------
 
 module GF.Speech.CFGToFiniteState (cfgToFA, makeSimpleRegular,
-                                   MFALabel(..), MFA(..), cfgToMFA,cfgToFA') where
+                                   MFA(..), MFALabel, cfgToMFA,cfgToFA') where
 
 import Data.List
 import Data.Maybe
@@ -51,14 +51,13 @@ type MutRecSets = Map Cat_ MutRecSet
 -- * Multiple DFA type
 --
 
-data MFALabel a = MFASym a | MFASub String
-                deriving (Eq,Ord)
+type MFALabel a = Symbol String a    
 
-data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))]
+data MFA a = MFA String [(String,DFA (MFALabel a))]
 
 
 
-cfgToFA :: Options -> StateGrammar -> DFA String
+cfgToFA :: Options -> StateGrammar -> DFA Token
 cfgToFA opts s = minimize $ compileAutomaton start $ makeSimpleRegular opts s
   where start = getStartCatCF opts s
 
@@ -123,27 +122,26 @@ make_fa c@(g,ns) q0 alpha q1 fa =
 -- * Compile a strongly regular grammar to a DFA with sub-automata
 --
 
-cfgToMFA :: Options -> StateGrammar -> MFA String
+cfgToMFA :: Options -> StateGrammar -> MFA Token
 cfgToMFA opts s = buildMFA start $ makeSimpleRegular opts s
   where start = getStartCatCF opts s
 
 -- | Build a DFA by building and expanding an MFA
-cfgToFA' :: Options -> StateGrammar -> DFA String
+cfgToFA' :: Options -> StateGrammar -> DFA Token
 cfgToFA' opts s = mfaToDFA $ cfgToMFA opts s
 
 buildMFA :: Cat_ -- ^ Start category
-         -> CFRules -> MFA String
+         -> CFRules -> MFA Token
 buildMFA start g = sortSubLats $ removeUnusedSubLats mfa
-  where startFA = let (fa,s,f) = newFA_
-                   in newTransition s f (MFASub start) fa
-        fas = compileAutomata g
-        mkMFALabel (Cat c) = MFASub c
-        mkMFALabel (Tok t) = MFASym t
-        toMFA = mapTransitions mkMFALabel
-        mfa = MFA startFA [(c, toMFA (minimize fa)) | (c,fa) <- fas]
+  where fas = compileAutomata g
+        mfa = MFA start [(c, minimize fa) | (c,fa) <- fas]
+
+mfaStartDFA :: MFA a -> DFA (MFALabel a)
+mfaStartDFA (MFA start subs) = 
+    fromMaybe (error $ "Bad start MFA: " ++ start) $ lookup start subs
 
 mfaToDFA :: Ord a => MFA a -> DFA a
-mfaToDFA (MFA main subs) = minimize $ expand $ dfa2nfa main
+mfaToDFA mfa@(MFA _ subs) = minimize $ expand $ dfa2nfa $ mfaStartDFA mfa
   where
   subs' = Map.fromList [(c, dfa2nfa n) | (c,n) <- subs]
   getSub l = fromJust $ Map.lookup l subs'
@@ -152,14 +150,14 @@ mfaToDFA (MFA main subs) = minimize $ expand $ dfa2nfa main
   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)
+             Just (Tok s) -> newTransition f t (Just s) fa
+             Just (Cat 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]
+removeUnusedSubLats mfa@(MFA start subs) = MFA start [(c,s) | (c,s) <- subs, isUsed c]
   where
   usedMap = subLatUseMap mfa
-  used = growUsedSet (usedSubLats main)
+  used = growUsedSet (Set.singleton start)
   isUsed c = c `Set.member` used
   growUsedSet = fix (\s -> foldl Set.union s $ mapMaybe (flip Map.lookup usedMap) $ Set.toList s)
 
@@ -167,7 +165,7 @@ subLatUseMap :: MFA a -> Map String (Set String)
 subLatUseMap (MFA _ subs) = Map.fromList [(c,usedSubLats n) | (c,n) <- subs]
 
 usedSubLats :: DFA (MFALabel a) -> Set String
-usedSubLats fa = Set.fromList [s | (_,_,MFASub s) <- transitions fa]
+usedSubLats fa = Set.fromList [s | (_,_,Cat s) <- transitions fa]
 
 revMultiMap :: (Ord a, Ord b) => Map a (Set b) -> Map b (Set a)
 revMultiMap m = Map.fromListWith Set.union [ (y,Set.singleton x) | (x,s) <- Map.toList m, y <- Set.toList s]
@@ -258,14 +256,6 @@ mutRecSets g = Map.fromList . concatMap mkMutRecSet
 -- * Utilities
 --
 
--- | 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'
-
 -- | Add a state for the given NFA for each of the categories
 --   in the given set. Returns a map of categories to their
 --   corresponding states.

src/GF/Speech/FiniteState.hs

@@ -15,7 +15,7 @@ module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
 			      startState, finalStates,
 			      states, transitions,
                               isInternal,
-			      newFA, 
+			      newFA, newFA_,
 			      addFinalState,
 			      newState, newStates,
                               newTransition, newTransitions,
@@ -73,6 +73,14 @@ newFA :: Enum n => a -- ^ Start node label
 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)
 

src/GF/Speech/PrRegExp.hs

@@ -11,6 +11,7 @@
 module GF.Speech.PrRegExp (regexpPrinter,multiRegexpPrinter) where
 
 import GF.Conversion.Types
+import GF.Formalism.Utilities
 import GF.Infra.Ident
 import GF.Infra.Option (Options)
 import GF.Speech.CFGToFiniteState
@@ -26,10 +27,7 @@ multiRegexpPrinter opts s = prREs $ mfa2res $ cfgToMFA opts s
 
 prREs :: [(String,RE (MFALabel String))] -> String
 prREs res = unlines [l ++ " = " ++ prRE (mapRE showLabel re) | (l,re) <- res]
-  where showLabel (MFASym s) = s
-        showLabel (MFASub l) = "<" ++ l ++ ">"
+  where showLabel = symbol (\l -> "<" ++ l ++ ">") id
 
 mfa2res :: MFA String -> [(String,RE (MFALabel String))]
-mfa2res (MFA start dfas) = 
-    [("START",f start)] ++ [(l,f dfa) | (l,dfa) <- dfas]
-  where f = minimizeRE . dfa2re
+mfa2res (MFA _ dfas) = [(l, minimizeRE (dfa2re dfa)) | (l,dfa) <- dfas]

src/GF/Speech/PrSLF.hs

@@ -24,7 +24,7 @@ module GF.Speech.PrSLF (slfPrinter,slfGraphvizPrinter,
 import GF.Data.Utilities
 import GF.Conversion.Types
 import GF.Formalism.CFG
-import GF.Formalism.Utilities (Symbol(..),symbol)
+import GF.Formalism.Utilities (Symbol(..),symbol,mapSymbol)
 import GF.Infra.Ident
 import GF.Infra.Option (Options)
 import GF.Infra.Print
@@ -56,7 +56,8 @@ type SLF_FA = FA State (Maybe (MFALabel String)) ()
 
 mkFAs :: Options -> StateGrammar -> (SLF_FA, [(String,SLF_FA)])
 mkFAs opts s = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
-  where MFA main subs = {- renameSubs $ -} cfgToMFA opts s
+  where MFA start subs = {- renameSubs $ -} cfgToMFA opts s
+        main = let (fa,s,f) = newFA_ in newTransition s f (Cat start) fa        
 
 slfStyleFA :: Eq a => DFA a -> FA State (Maybe a) ()
 slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing ()
@@ -64,13 +65,11 @@ slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothin
 
 -- | Give sequential names to subnetworks.
 renameSubs :: MFA String -> MFA String
-renameSubs (MFA main subs) = MFA (renameLabels main) subs'
+renameSubs (MFA start subs) = MFA (newName start) subs'
   where newNames = zip (map fst subs) ["sub"++show n | n <- [0..]]
         newName s = lookup' s newNames
         subs' = [(newName s,renameLabels n) | (s,n) <- subs]
-        renameLabels = mapTransitions renameLabel
-        renameLabel (MFASub x) = MFASub (newName x)
-        renameLabel l = l
+        renameLabels = mapTransitions (mapSymbol newName id)
 
 --
 -- * SLF graphviz printing (without sub-networks)
@@ -97,8 +96,7 @@ gvSLFFA :: Maybe String -> SLF_FA -> STM.State [State] Dot.Graph
 gvSLFFA n fa = 
     liftM (mkCluster n . faToGraphviz . mapStates (maybe "" mfaLabelToGv) 
             . mapTransitions (const "")) (rename fa)
-  where mfaLabelToGv (MFASym s) = s
-        mfaLabelToGv (MFASub s) = "#" ++ s
+  where mfaLabelToGv = symbol ("#"++) id
         mkCluster Nothing = id
         mkCluster (Just x) 
             = Dot.setName ("cluster_"++x) . Dot.setAttr "label" x
@@ -137,8 +135,8 @@ automatonToSLF mkNode fa = SLF { slfNodes = ns, slfEdges = es }
 mfaNodeToSLFNode :: Int -> Maybe (MFALabel String) -> SLFNode
 mfaNodeToSLFNode i l = case l of
                               Nothing -> mkSLFNode i Nothing
-                              Just (MFASym x) -> mkSLFNode i (Just x)
-                              Just (MFASub s) -> mkSLFSubLat i s
+                              Just (Tok x) -> mkSLFNode i (Just x)
+                              Just (Cat s) -> mkSLFSubLat i s
 
 mkSLFNode :: Int -> Maybe String -> SLFNode
 mkSLFNode i Nothing = SLFNode { nId = i, nWord = Nothing, nTag = Nothing }