Remove unused sub-networks when generating multiple FAs.

src/GF/Speech/CFGToFiniteState.hs

@@ -150,11 +150,11 @@ data MFALabel a = MFASym a | MFASub String
 data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))]
 
 --
--- * Compile strongly regular grammars to multiple DFAs
+-- * Compile a strongly regular grammar to a DFA with sub-automata
 --
 
 cfgToMFA :: Options -> CGrammar -> MFA String
-cfgToMFA opts g = MFA startFA [(c, toMFA (minimize fa)) | (c,fa) <- fas]
+cfgToMFA opts g = removeUnusedSubLats mfa
   where start = getStartCat opts
         startFA = let (fa,s,f) = newFA_
                    in newTransition s f (MFASub start) fa
@@ -162,6 +162,16 @@ cfgToMFA opts g = MFA startFA [(c, toMFA (minimize fa)) | (c,fa) <- fas]
         mkMFALabel (Cat c) = MFASub c
         mkMFALabel (Tok t) = MFASym t
         toMFA = mapTransitions mkMFALabel
+        mfa = MFA startFA [(c, toMFA (minimize fa)) | (c,fa) <- fas]
+
+removeUnusedSubLats :: MFA a -> MFA a
+removeUnusedSubLats (MFA main subs) = MFA main [(c,s) | (c,s) <- subs, isUsed c]
+  where
+  usedMap = Map.fromList [(c,usedSubLats n) | (c,n) <- subs]
+  used = growUsedSet (usedSubLats main)
+  isUsed c = c `Set.member` used
+  growUsedSet = fix (\s -> foldl Set.union s $ mapMaybe (flip Map.lookup usedMap) $ Set.toList s)
+  usedSubLats fa = Set.fromList [s | (_,_,MFASub s) <- transitions fa]
 
 -- | Convert a strongly regular grammar to a number of finite automata,
 --   one for each non-terminal.

src/GF/Speech/Graph.hs

@@ -18,6 +18,7 @@ module GF.Speech.Graph ( Graph(..), Node, Edge, NodeInfo
                         , nodeInfo
                         , getIncoming, getOutgoing, getNodeLabel
                         , inDegree, outDegree
+                        , nodeLabel
                         , edgeFrom, edgeTo, edgeLabel
                         , reverseGraph, renameNodes
                        ) where
@@ -149,6 +150,9 @@ groupEdgesBy f (Graph _ ns es) =
   where nm = Map.fromList [ (n, (x,[])) | (n,x) <- ns ]
 -}
 
+nodeLabel :: Node n a -> a
+nodeLabel = snd
+
 edgeFrom :: Edge n b -> n
 edgeFrom (f,_,_) = f
 

src/GF/Speech/PrSLF.hs

@@ -53,10 +53,13 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int }
 
 type SLF_FA = FA State (Maybe (MFALabel String)) ()
 
--- | Make a network with subnetworks in SLF
+slfStyleFA :: DFA (MFALabel String) -> SLF_FA
-slfPrinter :: Ident -- ^ Grammar name
+slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing () 
-	   -> Options -> CGrammar -> String
+             . moveLabelsToNodes . dfa2nfa
-slfPrinter name opts cfg = prSLFs (mfaToSLFs $ cfgToMFA opts cfg) ""
+
+--
+-- * SLF graphviz printing
+--
 
 slfGraphvizPrinter :: Ident -- ^ Grammar name
 	           -> Options -> CGrammar -> String
@@ -82,11 +85,23 @@ gvSLFFA n fa =
                     STM.put names'
                     return fa'
 
-mapMFA :: (DFA (MFALabel a) -> b) -> MFA a -> (b,[(String,b)])
+--
-mapMFA f (MFA main subs) = (f main, [(c, f fa) | (c,fa) <- subs])
+-- * SLF printing
+--
 
-slfStyleFA :: DFA (MFALabel String) -> SLF_FA
+-- | Make a network with subnetworks in SLF
-slfStyleFA = removeTrivialEmptyNodes . oneFinalState Nothing () . moveLabelsToNodes . dfa2nfa
+slfPrinter :: Ident -- ^ Grammar name
+	   -> Options -> CGrammar -> String
+slfPrinter name opts cfg = prSLFs (mfaToSLFs $ renameSubs $ cfgToMFA opts cfg) ""
+
+renameSubs :: MFA String -> MFA String
+renameSubs (MFA main subs) = MFA (renameLabels main) 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
 
 mfaToSLFs :: MFA String -> SLFs
 mfaToSLFs (MFA main subs) 
@@ -121,7 +136,7 @@ mkSLFEdge :: Int -> (Int,Int) -> SLFEdge
 mkSLFEdge i (f,t) = SLFEdge { eId = i, eStart = f, eEnd = t }
 
 prSLFs :: SLFs -> ShowS
-prSLFs (SLFs subs main) = unlinesS (map prSub subs) . prOneSLF main
+prSLFs (SLFs subs main) = unlinesS (map prSub subs ++ [prOneSLF main])
   where prSub (n,s) = showString "SUBLAT=" . shows n 
                       . nl . prOneSLF s . showString "." . nl