Sort sub-networks topologically. HTK's HBuild seems to require this.

2 files changed, 47 insertions, 25 deletions

diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs
index aad85b703..21d69efa9 100644
--- a/src/GF/Speech/CFGToFiniteState.hs
+++ b/src/GF/Speech/CFGToFiniteState.hs
@@ -154,7 +154,7 @@ data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))]
 --
 
 cfgToMFA :: Options -> CGrammar -> MFA String
-cfgToMFA opts g = removeUnusedSubLats mfa
+cfgToMFA opts g = sortSubLats $ removeUnusedSubLats mfa
   where start = getStartCat opts
         startFA = let (fa,s,f) = newFA_
                    in newTransition s f (MFASub start) fa
@@ -165,13 +165,32 @@ cfgToMFA opts g = removeUnusedSubLats mfa
         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]
+removeUnusedSubLats mfa@(MFA main subs) = MFA main [(c,s) | (c,s) <- subs, isUsed c]
   where
-  usedMap = Map.fromList [(c,usedSubLats n) | (c,n) <- subs]
+  usedMap = subLatUseMap mfa
   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]
+
+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]
+
+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]
+
+-- | Sort sub-networks topologically.
+sortSubLats :: MFA a -> MFA a
+sortSubLats mfa@(MFA main subs) = MFA main (reverse $ sortLats usedByMap subs)
+  where
+  usedByMap = revMultiMap (subLatUseMap mfa)
+  sortLats _ [] = []
+  sortLats ub ls = xs ++ sortLats ub' ys
+      where (xs,ys) = partition ((==0) . indeg) ls
+            ub' = Map.map (Set.\\ Set.fromList (map fst xs)) ub
+            indeg (c,_) = maybe 0 Set.size $ Map.lookup c ub
 
 -- | Convert a strongly regular grammar to a number of finite automata,
 --   one for each non-terminal.
diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs
index e837a0f3a..159d5b806 100644
--- a/src/GF/Speech/PrSLF.hs
+++ b/src/GF/Speech/PrSLF.hs
@@ -53,10 +53,24 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int }
 
 type SLF_FA = FA State (Maybe (MFALabel String)) ()
 
+mkFAs :: Options -> CGrammar -> (SLF_FA, [(String,SLF_FA)])
+mkFAs opts cfg = (slfStyleFA main, [(c,slfStyleFA n) | (c,n) <- subs])
+  where MFA main subs = {- renameSubs $ -} cfgToMFA opts cfg
+
 slfStyleFA :: DFA (MFALabel String) -> SLF_FA
 slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing () 
              . moveLabelsToNodes . dfa2nfa
 
+-- | Give sequential names to subnetworks.
+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
+
 --
 -- * SLF graphviz printing
 --
@@ -64,15 +78,15 @@ slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothin
 slfGraphvizPrinter :: Ident -- ^ Grammar name
 	           -> Options -> CGrammar -> String
 slfGraphvizPrinter name opts cfg = Dot.prGraphviz g
-  where MFA main subs = cfgToMFA opts cfg
+  where (main, subs) = mkFAs opts cfg
         g = STM.evalState (liftM2 Dot.addSubGraphs ss m) [0..] 
         ss = mapM (\ (c,f) -> gvSLFFA (Just c) f) subs
         m = gvSLFFA Nothing main
 
-gvSLFFA :: Maybe String -> DFA (MFALabel String) -> STM.State [State] Dot.Graph
+gvSLFFA :: Maybe String -> SLF_FA -> STM.State [State] Dot.Graph
 gvSLFFA n fa = 
     liftM (mkCluster n . faToGraphviz . mapStates (maybe "" mfaLabelToGv) 
-            . mapTransitions (const "")) (rename $ slfStyleFA fa)
+            . mapTransitions (const "")) (rename fa)
   where mfaLabelToGv (MFASym s) = s
         mfaLabelToGv (MFASub s) = "#" ++ s
         mkCluster Nothing = id
@@ -92,21 +106,10 @@ gvSLFFA n fa =
 -- | Make a network with subnetworks in SLF
 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) 
-    = SLFs [(c, dfaToSLF fa) | (c,fa) <- subs] (dfaToSLF main)
-  where dfaToSLF = automatonToSLF . slfStyleFA
+slfPrinter name opts cfg = prSLFs slfs ""
+  where 
+  (main,subs) = mkFAs opts cfg
+  slfs = SLFs [(c, automatonToSLF fa) | (c,fa) <- subs] (automatonToSLF main)
 
 automatonToSLF :: SLF_FA -> SLF
 automatonToSLF fa = SLF { slfNodes = ns, slfEdges = es }
@@ -115,9 +118,9 @@ automatonToSLF 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
+                              Nothing -> mkSLFNode i Nothing
+                              Just (MFASym x) -> mkSLFNode i (Just x)
+                              Just (MFASub s) -> mkSLFSubLat i s
 
 mkSLFNode :: Int -> Maybe String -> SLFNode
 mkSLFNode i Nothing = SLFNode { nId = i, nWord = Nothing, nTag = Nothing }