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 }