forked from GitHub/gf-core
Some tracing and formatting stuff looking for the the stack overflow problem in the FA generation.
This commit is contained in:
bringert
@@ -27,9 +27,13 @@ import GF.Speech.FiniteState
|
|||||||
import GF.Speech.Relation
|
import GF.Speech.Relation
|
||||||
import GF.Speech.TransformCFG
|
import GF.Speech.TransformCFG
|
||||||
|
|
||||||
|
import Debug.Trace
|
||||||
|
|
||||||
cfgToFA :: Options -> CGrammar -> DFA String
|
cfgToFA :: Options -> CGrammar -> DFA String
|
||||||
cfgToFA opts = minimize . compileAutomaton start . makeSimpleRegular
|
cfgToFA opts = minimize . compileAutomaton start . makeSimpleRegular
|
||||||
|
--cfgToFA opts = trfa "minimal" . minimize . trfa "initial" . compileAutomaton start . makeSimpleRegular
|
||||||
where start = getStartCat opts
|
where start = getStartCat opts
|
||||||
|
trfa s fa = trace (s ++ ", states: " ++ show (length (states fa)) ++ ", transitions: " ++ show (length (transitions fa))) fa
|
||||||
|
|
||||||
makeSimpleRegular :: CGrammar -> CFRules
|
makeSimpleRegular :: CGrammar -> CFRules
|
||||||
makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgToCFRules
|
makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgToCFRules
|
||||||
@@ -41,74 +45,76 @@ makeSimpleRegular = makeRegular . removeIdenticalRules . removeEmptyCats . cfgTo
|
|||||||
makeRegular :: CFRules -> CFRules
|
makeRegular :: CFRules -> CFRules
|
||||||
makeRegular g = groupProds $ concatMap trSet (mutRecCats True g)
|
makeRegular g = groupProds $ concatMap trSet (mutRecCats True g)
|
||||||
where trSet cs | allXLinear cs rs = rs
|
where trSet cs | allXLinear cs rs = rs
|
||||||
| otherwise = concatMap handleCat cs
|
| otherwise = concatMap handleCat cs
|
||||||
where rs = catSetRules g cs
|
where rs = catSetRules g cs
|
||||||
handleCat c = [CFRule c' [] (mkName (c++"-empty"))] -- introduce A' -> e
|
handleCat c = [CFRule c' [] (mkName (c++"-empty"))] -- introduce A' -> e
|
||||||
++ concatMap (makeRightLinearRules c) (catRules g c)
|
++ concatMap (makeRightLinearRules c) (catRules g c)
|
||||||
where c' = newCat c
|
where c' = newCat c
|
||||||
makeRightLinearRules b' (CFRule c ss n) =
|
makeRightLinearRules b' (CFRule c ss n) =
|
||||||
case ys of
|
case ys of
|
||||||
[] -> [CFRule b' (xs ++ [Cat (newCat c)]) n] -- no non-terminals left
|
[] -> [CFRule b' (xs ++ [Cat (newCat c)]) n] -- no non-terminals left
|
||||||
(Cat b:zs) -> CFRule b' (xs ++ [Cat b]) n
|
(Cat b:zs) -> CFRule b' (xs ++ [Cat b]) n
|
||||||
: makeRightLinearRules (newCat b) (CFRule c zs n)
|
: makeRightLinearRules (newCat b) (CFRule c zs n)
|
||||||
where (xs,ys) = break (`catElem` cs) ss
|
where (xs,ys) = break (`catElem` cs) ss
|
||||||
newCat c = c ++ "$"
|
newCat c = c ++ "$"
|
||||||
|
|
||||||
|
|
||||||
-- | Get the sets of mutually recursive non-terminals for a grammar.
|
-- | Get the sets of mutually recursive non-terminals for a grammar.
|
||||||
mutRecCats :: Bool -- ^ If true, all categories will be in some set.
|
mutRecCats :: Bool -- ^ If true, all categories will be in some set.
|
||||||
-- If false, only recursive categories will be included.
|
-- If false, only recursive categories will be included.
|
||||||
-> CFRules -> [[Cat_]]
|
-> CFRules -> [[Cat_]]
|
||||||
mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r
|
mutRecCats incAll g = equivalenceClasses $ refl $ symmetricSubrelation $ transitiveClosure r
|
||||||
where r = mkRel [(c,c') | (_,rs) <- g, CFRule c ss _ <- rs, Cat c' <- ss]
|
where r = mkRel [(c,c') | (_,rs) <- g, CFRule c ss _ <- rs, Cat c' <- ss]
|
||||||
allCats = map fst g
|
allCats = map fst g
|
||||||
refl = if incAll then reflexiveClosure_ allCats else reflexiveSubrelation
|
refl = if incAll then reflexiveClosure_ allCats else reflexiveSubrelation
|
||||||
|
|
||||||
-- Convert a strongly regular grammar to a finite automaton.
|
-- Convert a strongly regular grammar to a finite automaton.
|
||||||
compileAutomaton :: Cat_ -- ^ Start category
|
compileAutomaton :: Cat_ -- ^ Start category
|
||||||
-> CFRules
|
-> CFRules
|
||||||
-> NFA Token
|
-> NFA Token
|
||||||
compileAutomaton start g = make_fa s [Cat start] f fa''
|
compileAutomaton start g = make_fa s [Cat start] f fa''
|
||||||
where fa = newFA ()
|
where
|
||||||
s = startState fa
|
fa = newFA ()
|
||||||
(fa',f) = newState () fa
|
s = startState fa
|
||||||
fa'' = addFinalState f fa'
|
(fa',f) = newState () fa
|
||||||
ns = mutRecCats False g
|
fa'' = addFinalState f fa'
|
||||||
-- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\",
|
ns = mutRecCats False g
|
||||||
-- Mark-Jan Nederhof. International Workshop on Parsing Technologies, 1997.
|
-- | The make_fa algorithm from \"Regular approximation of CFLs: a grammatical view\",
|
||||||
make_fa :: State -> [Symbol Cat_ Token] -> State
|
-- Mark-Jan Nederhof. International Workshop on Parsing Technologies, 1997.
|
||||||
-> NFA Token -> NFA Token
|
make_fa :: State -> [Symbol Cat_ Token] -> State
|
||||||
make_fa q0 alpha q1 fa =
|
-> NFA Token -> NFA Token
|
||||||
case alpha of
|
make_fa q0 alpha q1 fa =
|
||||||
[] -> newTransition q0 q1 Nothing fa
|
case alpha of
|
||||||
[Tok t] -> newTransition q0 q1 (Just t) fa
|
[] -> newTransition q0 q1 Nothing fa
|
||||||
[Cat a] -> case findSet a ns of
|
[Tok t] -> newTransition q0 q1 (Just t) fa
|
||||||
-- a is recursive
|
[Cat a] -> case findSet a ns of
|
||||||
Just ni -> let (fa',ss) = addStatesForCats ni fa
|
-- a is recursive
|
||||||
getState x = lookup' x ss
|
Just ni -> let (fa',ss) = addStatesForCats ni fa
|
||||||
niRules = catSetRules g ni
|
getState x = lookup' x ss
|
||||||
(nrs,rs) = partition (ruleIsNonRecursive ni) niRules
|
niRules = catSetRules g ni
|
||||||
in if all (isRightLinear ni) niRules then
|
(nrs,rs) = partition (ruleIsNonRecursive ni) niRules
|
||||||
-- the set Ni is right-recursive or cyclic
|
in if all (isRightLinear ni) niRules
|
||||||
let fa'' = foldFuns [make_fa (getState c) xs q1 | CFRule c xs _ <- nrs] fa'
|
then
|
||||||
fa''' = foldFuns [make_fa (getState c) xs (getState d) | CFRule c ss _ <- rs,
|
-- the set Ni is right-recursive or cyclic
|
||||||
let (xs,Cat d) = (init ss,last ss)] fa''
|
let fa'' = foldFuns [make_fa (getState c) xs q1 | CFRule c xs _ <- nrs] fa'
|
||||||
in newTransition q0 (getState a) Nothing fa'''
|
fa''' = foldFuns [make_fa (getState c) xs (getState d) | CFRule c ss _ <- rs,
|
||||||
else
|
let (xs,Cat d) = (init ss,last ss)] fa''
|
||||||
-- the set Ni is left-recursive
|
in newTransition q0 (getState a) Nothing fa'''
|
||||||
let fa'' = foldFuns [make_fa q0 xs (getState c) | CFRule c xs _ <- nrs] fa'
|
else
|
||||||
fa''' = foldFuns [make_fa (getState d) xs (getState c) | CFRule c (Cat d:xs) _ <- rs] fa''
|
-- the set Ni is left-recursive
|
||||||
in newTransition (getState a) q1 Nothing fa'''
|
let fa'' = foldFuns [make_fa q0 xs (getState c) | CFRule c xs _ <- nrs] fa'
|
||||||
-- a is not recursive
|
fa''' = foldFuns [make_fa (getState d) xs (getState c) | CFRule c (Cat d:xs) _ <- rs] fa''
|
||||||
Nothing -> let rs = catRules g a
|
in newTransition (getState a) q1 Nothing fa'''
|
||||||
in foldl (\fa -> \ (CFRule _ b _) -> make_fa q0 b q1 fa) fa rs
|
-- a is not recursive
|
||||||
(x:beta) -> let (fa',q) = newState () fa
|
Nothing -> let rs = catRules g a
|
||||||
in make_fa q beta q1 $ make_fa q0 [x] q fa'
|
in foldl (\fa -> \ (CFRule _ b _) -> make_fa q0 b q1 fa) fa rs
|
||||||
addStatesForCats [] fa = (fa,[])
|
(x:beta) -> let (fa',q) = newState () fa
|
||||||
addStatesForCats (c:cs) fa = let (fa',s) = newState () fa
|
in make_fa q beta q1 $ make_fa q0 [x] q fa'
|
||||||
(fa'',ss) = addStatesForCats cs fa'
|
addStatesForCats [] fa = (fa,[])
|
||||||
in (fa'',(c,s):ss)
|
addStatesForCats (c:cs) fa = let (fa',s) = newState () fa
|
||||||
ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs
|
(fa'',ss) = addStatesForCats cs fa'
|
||||||
|
in (fa'',(c,s):ss)
|
||||||
|
ruleIsNonRecursive cs = noCatsInSet cs . ruleRhs
|
||||||
|
|
||||||
|
|
||||||
noCatsInSet :: Eq c => [c] -> [Symbol c t] -> Bool
|
noCatsInSet :: Eq c => [c] -> [Symbol c t] -> Bool
|
||||||
@@ -121,12 +127,12 @@ allXLinear cs rs = all (isRightLinear cs) rs || all (isLeftLinear cs) rs
|
|||||||
|
|
||||||
-- | Checks if a context-free rule is right-linear.
|
-- | Checks if a context-free rule is right-linear.
|
||||||
isRightLinear :: Eq c => [c] -- ^ The categories to consider
|
isRightLinear :: Eq c => [c] -- ^ The categories to consider
|
||||||
-> CFRule c n t -- ^ The rule to check for right-linearity
|
-> CFRule c n t -- ^ The rule to check for right-linearity
|
||||||
-> Bool
|
-> Bool
|
||||||
isRightLinear cs = noCatsInSet cs . safeInit . ruleRhs
|
isRightLinear cs = noCatsInSet cs . safeInit . ruleRhs
|
||||||
|
|
||||||
-- | Checks if a context-free rule is left-linear.
|
-- | Checks if a context-free rule is left-linear.
|
||||||
isLeftLinear :: Eq c => [c] -- ^ The categories to consider
|
isLeftLinear :: Eq c => [c] -- ^ The categories to consider
|
||||||
-> CFRule c n t -- ^ The rule to check for right-linearity
|
-> CFRule c n t -- ^ The rule to check for right-linearity
|
||||||
-> Bool
|
-> Bool
|
||||||
isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs
|
isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs
|
||||||
|
|||||||
@@ -34,10 +34,13 @@ import Data.Char (toUpper,toLower)
|
|||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
faGraphvizPrinter :: Ident -- ^ Grammar name
|
faGraphvizPrinter :: Ident -- ^ Grammar name
|
||||||
-> Options -> CGrammar -> String
|
-> Options -> CGrammar -> String
|
||||||
faGraphvizPrinter name opts cfg =
|
faGraphvizPrinter name opts cfg =
|
||||||
prFAGraphviz $ mapStates (const "") $ cfgToFA opts cfg
|
prFAGraphviz $ mapStates (const "") fa
|
||||||
|
where fa = cfgToFA opts cfg
|
||||||
|
|
||||||
|
|
||||||
-- | Convert the grammar to a regular grammar and print it in BNF
|
-- | Convert the grammar to a regular grammar and print it in BNF
|
||||||
|
|||||||
Reference in New Issue
Block a user