mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
Some performance improvements in the FA generation.
This commit is contained in:
bringert
@@ -34,11 +34,6 @@ lookupList a [] = []
|
||||
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
|
||||
| otherwise = lookupList a ps
|
||||
|
||||
-- | Find the first list in a list of lists
|
||||
-- which contains the argument.
|
||||
findSet :: Eq c => c -> [[c]] -> Maybe [c]
|
||||
findSet x = find (x `elem`)
|
||||
|
||||
split :: [a] -> ([a], [a])
|
||||
split (x : y : as) = (x:xs, y:ys)
|
||||
where (xs, ys) = split as
|
||||
|
||||
@@ -15,6 +15,10 @@
|
||||
module GF.Speech.CFGToFiniteState (cfgToFA, makeSimpleRegular) where
|
||||
|
||||
import Data.List
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import GF.Data.Utilities
|
||||
import GF.Formalism.CFG
|
||||
@@ -27,13 +31,19 @@ import GF.Speech.FiniteState
|
||||
import GF.Speech.Relation
|
||||
import GF.Speech.TransformCFG
|
||||
|
||||
import Debug.Trace
|
||||
data MutRecSet = MutRecSet {
|
||||
mrCats :: [Cat_],
|
||||
mrNonRecRules :: [CFRule_],
|
||||
mrRecRules :: [CFRule_],
|
||||
mrIsRightRec :: Bool
|
||||
}
|
||||
|
||||
|
||||
type MutRecSets = Map Cat_ MutRecSet
|
||||
|
||||
cfgToFA :: Options -> CGrammar -> DFA String
|
||||
cfgToFA opts = minimize . compileAutomaton start . makeSimpleRegular
|
||||
--cfgToFA opts = trfa "minimal" . minimize . trfa "initial" . compileAutomaton start . makeSimpleRegular
|
||||
where start = getStartCat opts
|
||||
trfa s fa = trace (s ++ ", states: " ++ show (length (states fa)) ++ ", transitions: " ++ show (length (transitions fa))) fa
|
||||
|
||||
makeSimpleRegular :: CGrammar -> CFRules
|
||||
makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgToCFRules
|
||||
@@ -45,8 +55,9 @@ makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgTo
|
||||
makeRegular :: CFRules -> CFRules
|
||||
makeRegular g = groupProds $ concatMap trSet (mutRecCats True g)
|
||||
where trSet cs | allXLinear cs rs = rs
|
||||
| otherwise = concatMap handleCat cs
|
||||
where rs = catSetRules g cs
|
||||
| otherwise = concatMap handleCat csl
|
||||
where csl = Set.toList cs
|
||||
rs = catSetRules g csl
|
||||
handleCat c = [CFRule c' [] (mkName (c++"-empty"))] -- introduce A' -> e
|
||||
++ concatMap (makeRightLinearRules c) (catRules g c)
|
||||
where c' = newCat c
|
||||
@@ -62,7 +73,7 @@ makeRegular g = groupProds $ concatMap trSet (mutRecCats True g)
|
||||
-- | Get the sets of mutually recursive non-terminals for a grammar.
|
||||
mutRecCats :: Bool -- ^ If true, all categories will be in some set.
|
||||
-- If false, only recursive categories will be included.
|
||||
-> CFRules -> [[Cat_]]
|
||||
-> CFRules -> [Set Cat_]
|
||||
mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r
|
||||
where r = mkRel [(c,c') | (_,rs) <- g, CFRule c ss _ <- rs, Cat c' <- ss]
|
||||
allCats = map fst g
|
||||
@@ -72,67 +83,88 @@ mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transit
|
||||
compileAutomaton :: Cat_ -- ^ Start category
|
||||
-> CFRules
|
||||
-> NFA Token
|
||||
compileAutomaton start g = make_fa s [Cat start] f fa''
|
||||
compileAutomaton start g = make_fa (g,ns) s [Cat start] f fa''
|
||||
where
|
||||
fa = newFA ()
|
||||
s = startState fa
|
||||
(fa',f) = newState () fa
|
||||
fa'' = addFinalState f fa'
|
||||
ns = mutRecCats False g
|
||||
-- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\",
|
||||
-- Mark-Jan Nederhof. International Workshop on Parsing Technologies, 1997.
|
||||
make_fa :: State -> [Symbol Cat_ Token] -> State
|
||||
ns = mutRecSets g $ mutRecCats False g
|
||||
|
||||
mutRecSets :: CFRules -> [Set Cat_] -> MutRecSets
|
||||
mutRecSets g = Map.fromList . concatMap mkMutRecSet
|
||||
where
|
||||
mkMutRecSet cs = [ (c,ms) | c <- csl ]
|
||||
where csl = Set.toList cs
|
||||
rs = catSetRules g csl
|
||||
(nrs,rrs) = partition (ruleIsNonRecursive cs) rs
|
||||
ms = MutRecSet {
|
||||
mrCats = csl,
|
||||
mrNonRecRules = nrs,
|
||||
mrRecRules = rrs,
|
||||
mrIsRightRec = all (isRightLinear cs) rrs
|
||||
}
|
||||
|
||||
-- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\",
|
||||
-- Mark-Jan Nederhof. International Workshop on Parsing Technologies, 1997.
|
||||
make_fa :: (CFRules,MutRecSets) -> State -> [Symbol Cat_ Token] -> State
|
||||
-> NFA Token -> NFA Token
|
||||
make_fa q0 alpha q1 fa =
|
||||
make_fa c@(g,ns) q0 alpha q1 fa =
|
||||
case alpha of
|
||||
[] -> newTransition q0 q1 Nothing fa
|
||||
[Tok t] -> newTransition q0 q1 (Just t) fa
|
||||
[Cat a] -> case findSet a ns of
|
||||
[Cat a] -> case Map.lookup a ns of
|
||||
-- a is recursive
|
||||
Just ni -> let (fa',ss) = addStatesForCats ni fa
|
||||
getState x = lookup' x ss
|
||||
niRules = catSetRules g ni
|
||||
(nrs,rs) = partition (ruleIsNonRecursive ni) niRules
|
||||
in if all (isRightLinear ni) niRules
|
||||
then
|
||||
-- the set Ni is right-recursive or cyclic
|
||||
let fa'' = foldFuns [make_fa (getState c) xs q1 | CFRule c xs _ <- nrs] fa'
|
||||
fa''' = foldFuns [make_fa (getState c) xs (getState d) | CFRule c ss _ <- rs,
|
||||
let (xs,Cat d) = (init ss,last ss)] fa''
|
||||
in newTransition q0 (getState a) Nothing fa'''
|
||||
else
|
||||
-- the set Ni is left-recursive
|
||||
let fa'' = foldFuns [make_fa q0 xs (getState c) | CFRule c xs _ <- nrs] fa'
|
||||
fa''' = foldFuns [make_fa (getState d) xs (getState c) | CFRule c (Cat d:xs) _ <- rs] fa''
|
||||
in newTransition (getState a) q1 Nothing fa'''
|
||||
Just n@(MutRecSet { mrCats = ni, mrNonRecRules = nrs, mrRecRules = rs} ) ->
|
||||
if mrIsRightRec n
|
||||
then
|
||||
-- the set Ni is right-recursive or cyclic
|
||||
let fa'' = foldl (\ f (CFRule c xs _) -> make_fa_ (getState c) xs q1 f) fa' nrs
|
||||
fa''' = foldl (\ f (CFRule c ss _) ->
|
||||
let (xs,Cat d) = (init ss,last ss)
|
||||
in make_fa_ (getState c) xs (getState d) f) fa'' rs
|
||||
in newTransition q0 (getState a) Nothing fa'''
|
||||
else
|
||||
-- the set Ni is left-recursive
|
||||
let fa'' = foldl (\f (CFRule c xs _) -> make_fa_ q0 xs (getState c) f) fa' nrs
|
||||
fa''' = foldl (\f (CFRule c (Cat d:xs) _) -> make_fa_ (getState d) xs (getState c) f) fa'' rs
|
||||
in newTransition (getState a) q1 Nothing fa'''
|
||||
where
|
||||
(fa',ss) = addStatesForCats ni fa
|
||||
getState x = lookup' x ss
|
||||
-- a is not recursive
|
||||
Nothing -> let rs = catRules g a
|
||||
in foldl (\fa -> \ (CFRule _ b _) -> make_fa q0 b q1 fa) fa rs
|
||||
in foldl (\fa -> \ (CFRule _ b _) -> make_fa_ q0 b q1 fa) fa rs
|
||||
(x:beta) -> let (fa',q) = newState () fa
|
||||
in make_fa q beta q1 $ make_fa q0 [x] q fa'
|
||||
addStatesForCats [] fa = (fa,[])
|
||||
addStatesForCats (c:cs) fa = let (fa',s) = newState () fa
|
||||
(fa'',ss) = addStatesForCats cs fa'
|
||||
in (fa'',(c,s):ss)
|
||||
ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs
|
||||
in make_fa_ q beta q1 $! make_fa_ q0 [x] q fa'
|
||||
where
|
||||
make_fa_ = make_fa c
|
||||
|
||||
addStatesForCats :: [Cat_] -> NFA Token -> (NFA Token, [(Cat_,State)])
|
||||
addStatesForCats cs fa = (fa', zip cs (map fst ns))
|
||||
where (fa', ns) = newStates (replicate (length cs) ()) fa
|
||||
|
||||
ruleIsNonRecursive :: Set Cat_ -> CFRule_ -> Bool
|
||||
ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs
|
||||
|
||||
|
||||
noCatsInSet :: Eq c => [c] -> [Symbol c t] -> Bool
|
||||
|
||||
noCatsInSet :: Set Cat_ -> [Symbol Cat_ t] -> Bool
|
||||
noCatsInSet cs = not . any (`catElem` cs)
|
||||
|
||||
-- | Check if all the rules are right-linear, or all the rules are
|
||||
-- left-linear, with respect to given categories.
|
||||
allXLinear :: Eq c => [c] -> [CFRule c n t] -> Bool
|
||||
allXLinear :: Set Cat_ -> [CFRule_] -> Bool
|
||||
allXLinear cs rs = all (isRightLinear cs) rs || all (isLeftLinear cs) rs
|
||||
|
||||
-- | Checks if a context-free rule is right-linear.
|
||||
isRightLinear :: Eq c => [c] -- ^ The categories to consider
|
||||
-> CFRule c n t -- ^ The rule to check for right-linearity
|
||||
isRightLinear :: Set Cat_ -- ^ The categories to consider
|
||||
-> CFRule_ -- ^ The rule to check for right-linearity
|
||||
-> Bool
|
||||
isRightLinear cs = noCatsInSet cs . safeInit . ruleRhs
|
||||
|
||||
-- | Checks if a context-free rule is left-linear.
|
||||
isLeftLinear :: Eq c => [c] -- ^ The categories to consider
|
||||
-> CFRule c n t -- ^ The rule to check for right-linearity
|
||||
isLeftLinear :: Set Cat_ -- ^ The categories to consider
|
||||
-> CFRule_ -- ^ The rule to check for right-linearity
|
||||
-> Bool
|
||||
isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs
|
||||
|
||||
@@ -16,7 +16,8 @@ module GF.Speech.FiniteState (FA, State, NFA, DFA,
|
||||
states, transitions,
|
||||
newFA,
|
||||
addFinalState,
|
||||
newState, newTransition,
|
||||
newState, newStates,
|
||||
newTransition,
|
||||
mapStates, mapTransitions,
|
||||
oneFinalState,
|
||||
moveLabelsToNodes, minimize,
|
||||
@@ -65,6 +66,10 @@ newState :: a -> FA n a b -> (FA n a b, n)
|
||||
newState x (FA g s ss) = (FA g' s ss, n)
|
||||
where (g',n) = newNode x g
|
||||
|
||||
newStates :: [a] -> FA n a b -> (FA n a b, [(n,a)])
|
||||
newStates xs (FA g s ss) = (FA g' s ss, ns)
|
||||
where (g',ns) = newNodes xs g
|
||||
|
||||
newTransition :: n -> n -> b -> FA n a b -> FA n a b
|
||||
newTransition f t l = onGraph (newEdge (f,t,l))
|
||||
|
||||
|
||||
@@ -13,7 +13,7 @@
|
||||
-----------------------------------------------------------------------------
|
||||
module GF.Speech.Graph ( Graph(..), Node, Edge, Incoming, Outgoing
|
||||
, newGraph, nodes, edges
|
||||
, nmap, emap, newNode, newEdge, newEdges
|
||||
, nmap, emap, newNode, newNodes, newEdge, newEdges
|
||||
, incoming, outgoing, getOutgoing
|
||||
, getFrom, getTo, getLabel
|
||||
, reverseGraph, renameNodes
|
||||
@@ -52,6 +52,11 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
|
||||
newNode :: a -> Graph n a b -> (Graph n a b,n)
|
||||
newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
|
||||
|
||||
newNodes :: [a] -> Graph n a b -> (Graph n a b,[Node n a])
|
||||
newNodes ls (Graph cs ns es) = (Graph cs' (ns'++ns) es, ns')
|
||||
where (xs,cs') = splitAt (length ls) cs
|
||||
ns' = zip xs ls
|
||||
|
||||
newEdge :: Edge n b -> Graph n a b -> Graph n a b
|
||||
newEdge e (Graph c ns es) = Graph c ns (e:es)
|
||||
|
||||
|
||||
@@ -100,10 +100,10 @@ purgeEmpty r = Map.filter (not . Set.null) r
|
||||
|
||||
|
||||
-- | Get the equivalence classes from an equivalence relation.
|
||||
equivalenceClasses :: Ord a => Rel a -> [[a]]
|
||||
equivalenceClasses :: Ord a => Rel a -> [Set a]
|
||||
equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
|
||||
where equivalenceClasses_ [] _ = []
|
||||
equivalenceClasses_ (x:xs) r = Set.toList ys:equivalenceClasses_ zs r
|
||||
equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
|
||||
where ys = allRelated r x
|
||||
zs = [x' | x' <- xs, not (x' `Set.member` ys)]
|
||||
|
||||
|
||||
@@ -37,6 +37,8 @@ import Control.Monad
|
||||
import Data.FiniteMap
|
||||
import Data.List
|
||||
import Data.Maybe (fromJust, fromMaybe)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
-- | not very nice to replace the structured CFCat type with a simple string
|
||||
@@ -134,8 +136,8 @@ ruleFun :: CFRule_ -> Fun
|
||||
ruleFun (CFRule _ _ n) = name2fun n
|
||||
|
||||
-- | Checks if a symbol is a non-terminal of one of the given categories.
|
||||
catElem :: Eq c => Symbol c t -> [c] -> Bool
|
||||
catElem s cs = symbol (`elem` cs) (const False) s
|
||||
catElem :: Symbol Cat_ t -> Set Cat_ -> Bool
|
||||
catElem s cs = symbol (`Set.member` cs) (const False) s
|
||||
|
||||
-- | Check if any of the categories used on the right-hand side
|
||||
-- are in the given list of categories.
|
||||
|
||||
Reference in New Issue
Block a user