diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Speech/CFGToFiniteState.hs | 14 | ||||
| -rw-r--r-- | src/GF/Speech/Graph.hs | 4 | ||||
| -rw-r--r-- | src/GF/Speech/PrSLF.hs | 33 |
3 files changed, 40 insertions, 11 deletions
diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs index 855bc8091..aad85b703 100644 --- a/src/GF/Speech/CFGToFiniteState.hs +++ b/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. diff --git a/src/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs index d018756d7..955c99d91 100644 --- a/src/GF/Speech/Graph.hs +++ b/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 diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs index bb8f5ddaf..e837a0f3a 100644 --- a/src/GF/Speech/PrSLF.hs +++ b/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 -slfPrinter :: Ident -- ^ Grammar name - -> Options -> CGrammar -> String -slfPrinter name opts cfg = prSLFs (mfaToSLFs $ cfgToMFA opts cfg) "" +slfStyleFA :: DFA (MFALabel String) -> SLF_FA +slfStyleFA = renameStates [0..] . removeTrivialEmptyNodes . oneFinalState Nothing () + . moveLabelsToNodes . dfa2nfa + +-- +-- * 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 -slfStyleFA = removeTrivialEmptyNodes . oneFinalState Nothing () . moveLabelsToNodes . dfa2nfa +-- | 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) @@ -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 |