msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

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.

Browse Source
This commit is contained in:
bringert
2007-06-25 16:25:58 +00:00
parent e967e040f9
commit ca8efaf3c7
4 changed files with 39 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

48
src/GF/Speech/CFGToFiniteState.hs
View File

@@ -13,7 +13,7 @@
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
module GF.Speech.CFGToFiniteState (cfgToFA, makeSimpleRegular, module GF.Speech.CFGToFiniteState (cfgToFA, makeSimpleRegular,
MFALabel(..), MFA(..), cfgToMFA,cfgToFA') where MFA(..), MFALabel, cfgToMFA,cfgToFA') where
import Data.List import Data.List
import Data.Maybe import Data.Maybe
@@ -51,14 +51,13 @@ type MutRecSets = Map Cat_ MutRecSet
-- * Multiple DFA type -- * Multiple DFA type
-- --
data MFALabel a = MFASym a | MFASub String type MFALabel a = Symbol String a
deriving (Eq,Ord)
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 cfgToFA opts s = minimize $ compileAutomaton start $ makeSimpleRegular opts s
where start = getStartCatCF 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 -- * 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 cfgToMFA opts s = buildMFA start $ makeSimpleRegular opts s
where start = getStartCatCF opts s where start = getStartCatCF opts s
-- | Build a DFA by building and expanding an MFA -- | 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 cfgToFA' opts s = mfaToDFA $ cfgToMFA opts s
buildMFA :: Cat_ -- ^ Start category buildMFA :: Cat_ -- ^ Start category
-> CFRules -> MFA String -> CFRules -> MFA Token
buildMFA start g = sortSubLats $ removeUnusedSubLats mfa buildMFA start g = sortSubLats $ removeUnusedSubLats mfa
where startFA = let (fa,s,f) = newFA_ where fas = compileAutomata g
in newTransition s f (MFASub start) fa mfa = MFA start [(c, minimize fa) | (c,fa) <- fas]
fas = compileAutomata g
mkMFALabel (Cat c) = MFASub c mfaStartDFA :: MFA a -> DFA (MFALabel a)
mkMFALabel (Tok t) = MFASym t mfaStartDFA (MFA start subs) =
toMFA = mapTransitions mkMFALabel fromMaybe (error $ "Bad start MFA: " ++ start) $ lookup start subs
mfa = MFA startFA [(c, toMFA (minimize fa)) | (c,fa) <- fas]
mfaToDFA :: Ord a => MFA a -> DFA a 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 where
subs' = Map.fromList [(c, dfa2nfa n) | (c,n) <- subs] subs' = Map.fromList [(c, dfa2nfa n) | (c,n) <- subs]
getSub l = fromJust $ Map.lookup l 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) = expandEdge fa (f,t,x) =
case x of case x of
Nothing -> newTransition f t Nothing fa Nothing -> newTransition f t Nothing fa
Just (MFASym s) -> newTransition f t (Just s) fa Just (Tok s) -> newTransition f t (Just s) fa
Just (MFASub l) -> insertNFA fa (f,t) (expand $ getSub l) Just (Cat l) -> insertNFA fa (f,t) (expand $ getSub l)
removeUnusedSubLats :: MFA a -> MFA a 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 where
usedMap = subLatUseMap mfa usedMap = subLatUseMap mfa
used = growUsedSet (usedSubLats main) used = growUsedSet (Set.singleton start)
isUsed c = c `Set.member` used isUsed c = c `Set.member` used
growUsedSet = fix (\s -> foldl Set.union s $ mapMaybe (flip Map.lookup usedMap) $ Set.toList s) 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] subLatUseMap (MFA _ subs) = Map.fromList [(c,usedSubLats n) | (c,n) <- subs]
usedSubLats :: DFA (MFALabel a) -> Set String 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 :: (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] 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 -- * 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 -- | Add a state for the given NFA for each of the categories
-- in the given set. Returns a map of categories to their -- in the given set. Returns a map of categories to their
-- corresponding states. -- corresponding states.

10
src/GF/Speech/FiniteState.hs
View File

@@ -15,7 +15,7 @@ module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
startState, finalStates, startState, finalStates,
states, transitions, states, transitions,
isInternal, isInternal,
newFA, newFA, newFA_,
addFinalState, addFinalState,
newState, newStates, newState, newStates,
newTransition, newTransitions, newTransition, newTransitions,
@@ -73,6 +73,14 @@ newFA :: Enum n => a -- ^ Start node label
newFA l = FA g s [] newFA l = FA g s []
where (g,s) = newNode l (newGraph [toEnum 0..]) 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 :: n -> FA n a b -> FA n a b
addFinalState f (FA g s ss) = FA g s (f:ss) addFinalState f (FA g s ss) = FA g s (f:ss)

8
src/GF/Speech/PrRegExp.hs
View File

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

18
src/GF/Speech/PrSLF.hs
View File

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