summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GF/Speech/CFGToFiniteState.hs49
-rw-r--r--src/GF/Speech/FiniteState.hs20
-rw-r--r--src/GF/Speech/Graph.hs47
-rw-r--r--src/GF/Speech/PrSLF.hs4
4 files changed, 72 insertions, 48 deletions
diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs
index 21d69efa9..b0d02983a 100644
--- a/src/GF/Speech/CFGToFiniteState.hs
+++ b/src/GF/Speech/CFGToFiniteState.hs
@@ -13,7 +13,7 @@
-----------------------------------------------------------------------------
module GF.Speech.CFGToFiniteState (cfgToFA, makeSimpleRegular,
- MFALabel(..), MFA(..), cfgToMFA) where
+ MFALabel(..), MFA(..), cfgToMFA,cfgToFA') where
import Data.List
import Data.Maybe
@@ -30,6 +30,7 @@ import GF.Infra.Ident (Ident)
import GF.Infra.Option (Options)
import GF.Speech.FiniteState
+import GF.Speech.Graph
import GF.Speech.Relation
import GF.Speech.TransformCFG
@@ -45,6 +46,17 @@ data MutRecSet = MutRecSet {
type MutRecSets = Map Cat_ MutRecSet
+--
+-- * Multiple DFA type
+--
+
+data MFALabel a = MFASym a | MFASub String
+ deriving Eq
+
+data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))]
+
+
+
cfgToFA :: Options -> CGrammar -> DFA String
cfgToFA opts = minimize . compileAutomaton start . makeSimpleRegular
where start = getStartCat opts
@@ -139,24 +151,22 @@ make_fa c@(g,ns) q0 alpha q1 fa =
make_fa_ = make_fa c
make_fas xs fa = foldl' (\f' (s1,xs,s2) -> make_fa_ s1 xs s2 f') fa xs
-
---
--- * Multiple DFA type
---
-
-data MFALabel a = MFASym a | MFASub String
- deriving Eq
-
-data MFA a = MFA (DFA (MFALabel a)) [(String,DFA (MFALabel a))]
-
--
-- * Compile a strongly regular grammar to a DFA with sub-automata
--
cfgToMFA :: Options -> CGrammar -> MFA String
-cfgToMFA opts g = sortSubLats $ removeUnusedSubLats mfa
+cfgToMFA opts g = buildMFA start g
where start = getStartCat opts
- startFA = let (fa,s,f) = newFA_
+
+-- | Build a DFA by building and expanding an MFA
+cfgToFA' :: Options -> CGrammar -> DFA String
+cfgToFA' opts g = mfaToDFA $ cfgToMFA opts g
+
+buildMFA :: Cat_ -- ^ Start category
+ -> CGrammar -> MFA String
+buildMFA start g = sortSubLats $ removeUnusedSubLats mfa
+ where startFA = let (fa,s,f) = newFA_
in newTransition s f (MFASub start) fa
fas = compileAutomata $ makeSimpleRegular g
mkMFALabel (Cat c) = MFASub c
@@ -164,6 +174,19 @@ cfgToMFA opts g = sortSubLats $ removeUnusedSubLats mfa
toMFA = mapTransitions mkMFALabel
mfa = MFA startFA [(c, toMFA (minimize fa)) | (c,fa) <- fas]
+mfaToDFA :: Ord a => MFA a -> DFA a
+mfaToDFA (MFA main subs) = minimize $ expand $ dfa2nfa main
+ where
+ subs' = Map.fromList [(c, dfa2nfa n) | (c,n) <- subs]
+ getSub l = fromJust $ Map.lookup l subs'
+ expand (FA (Graph c ns es) s f)
+ = foldl' expandEdge (FA (Graph c ns []) s f) es
+ expandEdge fa (f,t,x) =
+ case x of
+ Nothing -> newTransition f t Nothing fa
+ Just (MFASym s) -> newTransition f t (Just s) fa
+ Just (MFASub l) -> insertNFA fa (f,t) (expand $ getSub l)
+
removeUnusedSubLats :: MFA a -> MFA a
removeUnusedSubLats mfa@(MFA main subs) = MFA main [(c,s) | (c,s) <- subs, isUsed c]
where
diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index 094806b0d..6b764cdb1 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/src/GF/Speech/FiniteState.hs
@@ -11,15 +11,17 @@
--
-- A simple finite state network module.
-----------------------------------------------------------------------------
-module GF.Speech.FiniteState (FA, State, NFA, DFA,
+module GF.Speech.FiniteState (FA(..), State, NFA, DFA,
startState, finalStates,
states, transitions,
newFA,
addFinalState,
newState, newStates,
- newTransition,
+ newTransition, newTransitions,
mapStates, mapTransitions,
oneFinalState,
+ insertNFA,
+ onGraph,
moveLabelsToNodes, removeTrivialEmptyNodes,
minimize,
dfa2nfa,
@@ -77,6 +79,9 @@ newStates xs (FA g s ss) = (FA g' s ss, ns)
newTransition :: n -> n -> b -> FA n a b -> FA n a b
newTransition f t l = onGraph (newEdge (f,t,l))
+newTransitions :: [(n, n, b)] -> FA n a b -> FA n a b
+newTransitions es = onGraph (newEdges es)
+
mapStates :: (a -> c) -> FA n a b -> FA n c b
mapStates f = onGraph (nmap f)
@@ -100,6 +105,17 @@ renameStates supply (FA g s fs) = FA (renameNodes newName rest g) s' fs'
s' = newName s
fs' = map newName fs
+-- | Insert an NFA into another
+insertNFA :: NFA a -- ^ NFA to insert into
+ -> (State, State) -- ^ States to insert between
+ -> NFA a -- ^ NFA to insert.
+ -> NFA a
+insertNFA (FA g1 s1 fs1) (f,t) (FA g2 s2 fs2)
+ = FA (newEdges es g') s1 fs1
+ where
+ es = (f,ren s2,Nothing):[(ren f2,t,Nothing) | f2 <- fs2]
+ (g',ren) = mergeGraphs g1 g2
+
onGraph :: (Graph n a b -> Graph n c d) -> FA n a b -> FA n c d
onGraph f (FA g s ss) = FA (f g) s ss
diff --git a/src/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs
index 955c99d91..c23c5e384 100644
--- a/src/GF/Speech/Graph.hs
+++ b/src/GF/Speech/Graph.hs
@@ -20,7 +20,7 @@ module GF.Speech.Graph ( Graph(..), Node, Edge, NodeInfo
, inDegree, outDegree
, nodeLabel
, edgeFrom, edgeTo, edgeLabel
- , reverseGraph, renameNodes
+ , reverseGraph, mergeGraphs, renameNodes
) where
import GF.Data.Utilities
@@ -120,36 +120,6 @@ outDegree i n = length $ getOutgoing i n
getNodeLabel :: Ord n => NodeInfo n a b -> n -> a
getNodeLabel i n = let (l,_,_) = lookupNode i n in l
-{-
--- | Get a map of nodes and their incoming edges.
-incoming :: Ord n => Graph n a b -> Incoming n a b
-incoming = groupEdgesBy getTo
-
--- | Get all edges ending at a given node.
-getIncoming :: Ord n => Incoming n a b -> n -> [Edge n b]
-getIncoming out x = maybe [] snd (Map.lookup x out)
-
-incomingToList :: Incoming n a b -> [(Node n a, [Edge n b])]
-incomingToList out = [ ((n,x),es) | (n,(x,es)) <- Map.toList out ]
-
--- | Get a map of nodes and their outgoing edges.
-outgoing :: Ord n => Graph n a b -> Outgoing n a b
-outgoing = groupEdgesBy getFrom
-
--- | Get all edges starting at a given node.
-getOutgoing :: Ord n => Outgoing n a b -> n -> [Edge n b]
-getOutgoing out x = maybe [] snd (Map.lookup x out)
-
--- | Get the label of a node given its outgoing list.
-getLabelOut :: Ord n => Outgoing n a b -> n -> a
-getLabelOut out x = fst $ fromJust (Map.lookup x out)
-
-groupEdgesBy :: (Ord n) => (Edge n b -> n) -> Graph n a b -> Map n (a,[Edge n b])
-groupEdgesBy f (Graph _ ns es) =
- foldl' (\m e -> Map.adjust (\ (x,el) -> (x,e:el)) (f e) m) nm es
- where nm = Map.fromList [ (n, (x,[])) | (n,x) <- ns ]
--}
-
nodeLabel :: Node n a -> a
nodeLabel = snd
@@ -165,6 +135,21 @@ edgeLabel (_,_,l) = l
reverseGraph :: Graph n a b -> Graph n a b
reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
+-- | Add the nodes from the second graph to the first graph.
+-- The nodes in the second graph will be renamed using the name
+-- supply in the first graph.
+-- This function is more efficient when the second graph
+-- is smaller than the first.
+mergeGraphs :: Ord m => Graph n a b -> Graph m a b
+ -> (Graph n a b, m -> n) -- ^ The new graph and a function translating
+ -- the old names of nodes in the second graph
+ -- to names in the new graph.
+mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
+ where
+ (xs,c') = splitAt (length (nodes g2)) c
+ newNames = Map.fromList (zip (map fst (nodes g2)) xs)
+ newName n = fromJust $ Map.lookup n newNames
+ Graph _ ns2 es2 = renameNodes newName undefined g2
-- | Rename the nodes in the graph.
renameNodes :: (n -> m) -- ^ renaming function
diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs
index 897113a03..ba7dea3c8 100644
--- a/src/GF/Speech/PrSLF.hs
+++ b/src/GF/Speech/PrSLF.hs
@@ -78,7 +78,7 @@ renameSubs (MFA main subs) = MFA (renameLabels main) subs'
slfGraphvizPrinter :: Ident -> Options -> CGrammar -> String
slfGraphvizPrinter name opts cfg
- = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA opts cfg
+ = prFAGraphviz $ gvFA $ slfStyleFA $ cfgToFA' opts cfg
where
gvFA = mapStates (fromMaybe "") . mapTransitions (const "")
@@ -116,7 +116,7 @@ gvSLFFA n fa =
slfPrinter :: Ident -> Options -> CGrammar -> String
slfPrinter name opts cfg
- = prSLF (automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA opts cfg) ""
+ = prSLF (automatonToSLF mkSLFNode $ slfStyleFA $ cfgToFA' opts cfg) ""
--
-- * SLF printing (with sub-networks)
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 13:54:58 +0000