diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs new file mode 100644 index 000000000..0f121fec5 --- /dev/null +++ b/src/GF/Speech/CFGToFiniteState.hs @@ -0,0 +1,171 @@ +---------------------------------------------------------------------- +-- | +-- Module : CFGToFiniteState +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/12 15:46:44 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.1 $ +-- +-- Approximates CFGs with finite state networks. +----------------------------------------------------------------------------- + +module GF.Speech.CFGToFiniteState (cfgToFA) where + +import Data.List + +import GF.Formalism.CFG +import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, NameProfile(..)) +import GF.Conversion.Types +import GF.Infra.Ident (Ident) +import GF.Infra.Option (Options) + +import GF.Speech.FiniteState +import GF.Speech.TransformCFG + +cfgToFA :: Ident -- ^ Grammar name + -> Options -> CGrammar -> FA () (Maybe String) +cfgToFA name opts cfg = minimize $ compileAutomaton start rgr + where start = getStartCat opts + rgr = makeRegular $ removeIdenticalRules $ removeEmptyCats $ cfgToCFRules cfg + + +-- Use the transformation algorithm from \"Regular Approximation of Context-free +-- Grammars through Approximation\", Mohri and Nederhof, 2000 +-- to create an over-generating regular frammar for a context-free +-- grammar +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 + handleCat c = [CFRule c' [] (mkName (c++"-empty"))] -- introduce A' -> e + ++ concatMap (makeRightLinearRules c) (catRules g c) + where c' = newCat c + makeRightLinearRules b' (CFRule c ss n) = + case ys of + [] -> [CFRule b' (xs ++ [Cat (newCat c)]) n] -- no non-terminals left + (Cat b:zs) -> CFRule b' (xs ++ [Cat b]) n + : makeRightLinearRules (newCat b) (CFRule c zs n) + where (xs,ys) = break (`catElem` cs) ss + newCat c = c ++ "$" + + +-- | 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_]] +mutRecCats incAll g = equivalenceClasses $ symmetricSubrelation $ transitiveClosure r' + where r = nub [(c,c') | (_,rs) <- g, CFRule c ss _ <- rs, Cat c' <- ss] + allCats = map fst g + r' = (if incAll then reflexiveClosure allCats else id) r + +-- Convert a strongly regular grammar to a finite automaton. +compileAutomaton :: Cat_ -- ^ Start category + -> CFRules + -> FA () (Maybe Token) +compileAutomaton start g = make_fa 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 + -> FA () (Maybe Token) -> FA () (Maybe Token) + make_fa 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 + -- 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''' + -- a is not recursive + Nothing -> let rs = catRules g a + in foldr (\ (CFRule _ b _) -> make_fa q0 b q1) 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 + + +noCatsInSet :: Eq c => [c] -> [Symbol c 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 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 + -> 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 + -> Bool +isLeftLinear cs = noCatsInSet cs . drop 1 . ruleRhs + + +-- +-- * Relations +-- + +-- FIXME: these could use a more efficent data structures and algorithms. + +type Rel a = [(a,a)] + +isRelatedTo :: Eq a => Rel a -> a -> a -> Bool +isRelatedTo r x y = (x,y) `elem` r + +transitiveClosure :: Eq a => Rel a -> Rel a +transitiveClosure r = fix (\r -> r `union` [ (x,w) | (x,y) <- r, (z,w) <- r, y == z ]) r + +reflexiveClosure :: Eq a => [a] -- ^ The set over which the relation is defined. + -> Rel a -> Rel a +reflexiveClosure u r = [(x,x) | x <- u] `union` r + +symmetricSubrelation :: Eq a => Rel a -> Rel a +symmetricSubrelation r = [p | p@(x,y) <- r, (y,x) `elem` r] + +-- | Get the equivalence classes from an equivalence relation. Since +-- the relation is relexive, the set can be recoved from the relation. +equivalenceClasses :: Eq a => Rel a -> [[a]] +equivalenceClasses r = equivalenceClasses_ (nub (map fst r)) r + where equivalenceClasses_ [] _ = [] + equivalenceClasses_ (x:xs) r = (x:ys):equivalenceClasses_ zs r + where (ys,zs) = partition (isRelatedTo r x) xs + +-- +-- * Utilities +-- + +foldFuns :: [a -> a] -> a -> a +foldFuns fs x = foldr ($) x fs + +safeInit :: [a] -> [a] +safeInit [] = [] +safeInit xs = init xs \ No newline at end of file diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs index 671efb3d7..8340aa361 100644 --- a/src/GF/Speech/FiniteState.hs +++ b/src/GF/Speech/FiniteState.hs @@ -1,9 +1,22 @@ +---------------------------------------------------------------------- +-- | +-- Module : FiniteState +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/12 15:46:44 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.3 $ +-- +-- A simple finite state network module. +----------------------------------------------------------------------------- module GF.Speech.FiniteState (FA, State, startState, finalStates, states, transitions, newFA, addFinalState, - newState, newTrans, - moveLabelsToNodes) where + newState, newTransition, newTransitions, + moveLabelsToNodes, minimize, asGraph) where import Data.Graph.Inductive import Data.List (nub,partition) @@ -41,8 +54,20 @@ newState :: a -> FA a b -> (FA a b, State) newState x (FA g s ss) = (FA g' s ss, n) where (g',n) = addNode x g -newTrans :: Node -> Node -> b -> FA a b -> FA a b -newTrans f t l = onGraph (insEdge (f,t,l)) +newTransition :: Node -> Node -> b -> FA a b -> FA a b +newTransition f t l = onGraph (insEdge (f,t,l)) + +newTransitions :: [(Node,Node,b)] -> FA a b -> FA a b +newTransitions ts = onGraph (insEdges ts) + +mapStates :: (a -> c) -> FA a b -> FA c b +mapStates f (FA g s ss) = FA (nmap f g) s ss + +asGraph :: FA a b -> Gr a b +asGraph (FA g _ _) = g + +minimize :: FA () (Maybe a) -> FA () (Maybe a) +minimize = onGraph mimimizeGr1 -- -- * Graph functions @@ -111,6 +136,17 @@ ledgeToEdge (f,t,_) = (f,t) addContexts :: DynGraph gr => [Context a b] -> gr a b -> gr a b addContexts cs gr = foldr (&) gr cs +mimimizeGr1 :: DynGraph gr => gr () (Maybe a) -> gr () (Maybe a) +mimimizeGr1 = removeEmptyLoops + +removeEmptyLoops :: DynGraph gr => gr () (Maybe a) -> gr () (Maybe a) +removeEmptyLoops = gmap (\ (i,n,(),o) -> (filter (r n) i,n,(),filter (r n) o)) + where r n (Nothing,n') | n' == n = False + r _ _ = True + +mimimizeGr2 :: DynGraph gr => gr (Maybe a) () -> gr (Maybe a) () +mimimizeGr2 gr = gr + -- -- * Utilities -- diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs index 9fe7d20ee..94ac10f15 100644 --- a/src/GF/Speech/PrSLF.hs +++ b/src/GF/Speech/PrSLF.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/07 14:21:30 $ +-- > CVS $Date: 2005/09/12 15:46:44 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ +-- > CVS $Revision: 1.4 $ -- -- This module converts a CFG to an SLF finite-state network -- for use with the ATK recognizer. The SLF format is described @@ -18,10 +18,11 @@ -- categories in the grammar ----------------------------------------------------------------------------- -module GF.Speech.PrSLF (slfPrinter) where +module GF.Speech.PrSLF (slfPrinter,slfGraphvizPrinter,faGraphvizPrinter) where import GF.Speech.SRG import GF.Speech.TransformCFG +import GF.Speech.CFGToFiniteState import GF.Speech.FiniteState import GF.Infra.Ident @@ -34,6 +35,9 @@ import GF.Infra.Option import Data.Char (toUpper,toLower) import Data.Maybe (fromMaybe) +import Data.Graph.Inductive (emap,nmap) +import Data.Graph.Inductive.Graphviz + data SLF = SLF { slfNodes :: [SLFNode], slfEdges :: [SLFEdge] } data SLFNode = SLFNode { nId :: Int, nWord :: SLFWord } @@ -46,31 +50,35 @@ data SLFEdge = SLFEdge { eId :: Int, eStart :: Int, eEnd :: Int } slfPrinter :: Ident -- ^ Grammar name -> Options -> CGrammar -> String -slfPrinter name opts cfg = prSLF (regularToSLF start rgr) "" - where start = getStartCat opts - rgr = makeRegular $ removeEmptyCats $ cfgToCFRules cfg +slfPrinter name opts cfg = prSLF (automatonToSLF $ moveLabelsToNodes $ cfgToFA name opts cfg) "" -regularToSLF :: String -> CFRules -> SLF -regularToSLF s rs = automatonToSLF $ compileAutomaton s rs +slfGraphvizPrinter :: Ident -- ^ Grammar name + -> Options -> CGrammar -> String +slfGraphvizPrinter name opts cfg = + graphviz (nmap (fromMaybe "") $ asGraph $ moveLabelsToNodes $ cfgToFA name opts cfg) (prIdent name) (8.5,11.0) (1,1) Landscape -automatonToSLF :: FA () (Maybe String) -> SLF +faGraphvizPrinter :: Ident -- ^ Grammar name + -> Options -> CGrammar -> String +faGraphvizPrinter name opts cfg = + graphviz (nmap (const "") $ emap (fromMaybe "") $ asGraph $ cfgToFA name opts cfg) (prIdent name) (8.5,11.0) (1,1) Landscape + +automatonToSLF :: FA (Maybe String) () -> SLF automatonToSLF fa = - SLF { slfNodes = map mkSLFNode (states fa'), - slfEdges = zipWith mkSLFEdge [0..] (transitions fa') } - where fa' = moveLabelsToNodes fa - mkSLFNode (i,w) = SLFNode { nId = i, nWord = w } + SLF { slfNodes = map mkSLFNode (states fa), + slfEdges = zipWith mkSLFEdge [0..] (transitions fa) } + where mkSLFNode (i,w) = SLFNode { nId = i, nWord = w } mkSLFEdge i (f,t,()) = SLFEdge { eId = i, eStart = f, eEnd = t } prSLF :: SLF -> ShowS -prSLF (SLF { slfNodes = ns, slfEdges = es}) = header . unlinesS (map prNode ns) . unlinesS (map prEdge es) +prSLF (SLF { slfNodes = ns, slfEdges = es}) + = header . unlinesS (map prNode ns) . nl . unlinesS (map prEdge es) . nl where header = showString "VERSION=1.0" . nl . prFields [("N",show (length ns)),("L", show (length es))] . nl prNode n = prFields [("I",show (nId n)),("W",showWord (nWord n))] prEdge e = prFields [("J",show (eId e)),("S",show (eStart e)),("E",show (eEnd e))] - showWord :: SLFWord -> String showWord Nothing = "!NULL" showWord (Just w) = w -- FIXME: convert words to upper case diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs index 9f4919ed2..6d88a677e 100644 --- a/src/GF/Speech/SRG.hs +++ b/src/GF/Speech/SRG.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/07 14:21:30 $ +-- > CVS $Date: 2005/09/12 15:46:44 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.15 $ +-- > CVS $Revision: 1.16 $ -- -- Representation of, conversion to, and utilities for -- printing of a general Speech Recognition Grammar. @@ -58,24 +58,18 @@ makeSRG i opts gr = SRG { grammarName = name, where name = prIdent i origStart = getStartCat opts - gr' = removeLeftRecursion $ removeEmptyCats $ cfgToCFRules gr + gr' = removeLeftRecursion $ removeIdenticalRules $ removeEmptyCats $ cfgToCFRules gr (cats,cfgRules) = unzip gr' names = mkCatNames name cats cfgRulesToSRGRule :: FiniteMap String String -> [CFRule_] -> SRGRule cfgRulesToSRGRule names rs@(r:_) = SRGRule cat origCat rhs - where origCat = ruleCat r + where origCat = lhsCat r cat = lookupFM_ names origCat rhs = nub $ map (map renameCat . ruleRhs) rs renameCat (Cat c) = Cat (lookupFM_ names c) renameCat t = t -ruleCat :: CFRule c n t -> c -ruleCat (CFRule c _ _) = c - -ruleRhs :: CFRule c n t -> [Symbol c t] -ruleRhs (CFRule _ r _) = r - mkCatNames :: String -- ^ Category name prefix -> [String] -- ^ Original category names -> FiniteMap String String -- ^ Maps original names to SRG names diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs index 5f1e4fb97..57d8ec87b 100644 --- a/src/GF/Speech/TransformCFG.hs +++ b/src/GF/Speech/TransformCFG.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/08 15:45:17 $ +-- > CVS $Date: 2005/09/12 15:46:44 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.19 $ +-- > CVS $Revision: 1.20 $ -- -- This module does some useful transformations on CFGs. -- @@ -16,12 +16,12 @@ -- peb thinks: most of this module should be moved to GF.Conversion... ----------------------------------------------------------------------------- -module GF.Speech.TransformCFG (CFRule_, CFRules, +-- FIXME: lots of this stuff is used by CFGToFiniteState, thus +-- the missing explicit expot list. +module GF.Speech.TransformCFG {- (CFRule_, CFRules, cfgToCFRules, getStartCat, removeLeftRecursion, - removeEmptyCats, - makeRegular, - compileAutomaton) where + removeEmptyCats, removeIdenticalRules) -} where import GF.Infra.Ident import GF.Formalism.CFG @@ -62,8 +62,6 @@ groupProds = fmToList . addListToFM_C (++) emptyFM . map (\r -> (lhsCat r,[r])) ungroupProds :: CFRules -> [CFRule_] ungroupProds = concat . map snd -catRules :: CFRules -> Cat_ -> [CFRule_] -catRules rs c = fromMaybe [] (lookup c rs) -- | Remove productions which use categories which have no productions removeEmptyCats :: CFRules -> CFRules @@ -77,13 +75,18 @@ removeEmptyCats = fix removeEmptyCats' emptyCats = filter (nothingOrNull . flip lookup rs) allCats k' = map (\ (c,xs) -> (c, filter (not . anyUsedBy emptyCats) xs)) keep +-- | Remove rules which are identical, not caring about the rule names. +removeIdenticalRules :: CFRules -> CFRules +removeIdenticalRules g = [(c,nubBy sameCatAndRhs rs) | (c,rs) <- g] + where sameCatAndRhs (CFRule c1 ss1 _) (CFRule c2 ss2 _) = c1 == c2 && ss1 == ss2 + removeLeftRecursion :: CFRules -> CFRules removeLeftRecursion rs = concatMap removeDirectLeftRecursion $ map handleProds rs where handleProds (c, r) = (c, concatMap handleProd r) handleProd (CFRule ai (Cat aj:alpha) n) | aj < ai = -- FIXME: this will give multiple rules with the same name - [CFRule ai (beta ++ alpha) n | CFRule _ beta _ <- fromJust (lookup aj rs)] + [CFRule ai (beta ++ alpha) n | CFRule _ beta _ <- lookup' aj rs] handleProd r = [r] removeDirectLeftRecursion :: (Cat_,[CFRule_]) -- ^ All productions for a category @@ -103,92 +106,22 @@ isDirectLeftRecursive (CFRule c (Cat c':_) _) = c == c' isDirectLeftRecursive _ = False --- Use the transformation algorithm from \"Regular Approximation of Context-free --- Grammars through Approximation\", Mohri and Nederhof, 2000 --- to create an over-generating regular frammar for a context-free --- grammar -makeRegular :: CFRules -> CFRules -makeRegular g = groupProds $ concatMap trSet (mutRecCats g) - where trSet cs | allXLinear cs rs = rs - | otherwise = concatMap handleCat cs - where rs = concatMap (catRules g) cs - handleCat c = [CFRule c' [] (mkName (c++"-empty"))] -- introduce A' -> e - ++ concatMap (makeRightLinearRules c) (catRules g c) - where c' = newCat c - makeRightLinearRules b' (CFRule c ss n) = - case ys of - [] -> [CFRule b' (xs ++ [Cat (newCat c)]) n] -- no non-terminals left - (Cat b:zs) -> CFRule b' (xs ++ [Cat b]) n - : makeRightLinearRules (newCat b) (CFRule c zs n) - where (xs,ys) = break (`catElem` cs) ss - newCat c = c ++ "$" - - --- | Get the sets of mutually recursive non-terminals for a grammar. -mutRecCats :: CFRules -> [[Cat_]] -mutRecCats g = equivalenceClasses $ symmetricSubrelation $ transitiveClosure $ reflexiveClosure allCats r - where r = nub [(c,c') | (_,rs) <- g, CFRule c ss _ <- rs, Cat c' <- ss] - allCats = map fst g - - - --- Convert a strongly regular grammar to a finite automaton. -compileAutomaton :: Cat_ -- ^ Start category - -> CFRules - -> FA () (Maybe Token) -compileAutomaton start g = make_fa s [Cat start] f g fa'' - where fa = newFA () - s = startState fa - (fa',f) = newState () fa - fa'' = addFinalState f fa' - --- | 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 - -> CFRules -> FA () (Maybe Token) -> FA () (Maybe Token) -make_fa q0 a q1 g fa = - case a of - [] -> newTrans q0 q1 Nothing fa - [Tok t] -> newTrans q0 q1 (Just t) fa - [Cat c] -> undefined - (x:beta) -> let (fa',q) = newState () fa - fa'' = make_fa q0 [x] q g fa' - fa''' = make_fa q beta q1 g fa'' - in fa''' - -- -- * CFG rule utilities -- -{- --- | Get all the rules for a given category. -catRules :: Eq c => [CFRule c n t] -> c -> [CFRule c n t] -catRules rs c = [r | r@(CFRule c' _ _) <- rs, c' == c] --} +catRules :: CFRules -> Cat_ -> [CFRule_] +catRules rs c = fromMaybe [] (lookup c rs) --- | Gets the set of LHS categories of a set of rules. -lhsCats :: Eq c => [CFRule c n t] -> [c] -lhsCats = nub . map lhsCat +catSetRules :: CFRules -> [Cat_] -> [CFRule_] +catSetRules g s = concatMap (catRules g) s lhsCat :: CFRule c n t -> c lhsCat (CFRule c _ _) = c --- | 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 cs rs = all (isRightLinear cs) rs || all (isLeftLinear cs) rs +ruleRhs :: CFRule c n t -> [Symbol c t] +ruleRhs (CFRule _ ss _) = ss --- | 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 - -> Bool -isRightLinear cs (CFRule _ ss _) = all (not . (`catElem` cs)) (safeInit ss) - --- | 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 - -> Bool -isLeftLinear cs (CFRule _ ss _) = all (not . (`catElem` cs)) (drop 1 ss) -- | Checks if a symbol is a non-terminal of one of the given categories. catElem :: Eq c => Symbol c t -> [c] -> Bool @@ -202,37 +135,14 @@ anyUsedBy cs (CFRule _ ss _) = any (`elem` cs) (filterCats ss) mkName :: String -> Name mkName n = Name (IC n) [] --- --- * Relations --- - --- FIXME: these could use a more efficent data structures and algorithms. - -isRelatedTo :: Eq a => [(a,a)] -> a -> a -> Bool -isRelatedTo r x y = (x,y) `elem` r - -transitiveClosure :: Eq a => [(a,a)] -> [(a,a)] -transitiveClosure r = fix (\r -> r `union` [ (x,w) | (x,y) <- r, (z,w) <- r, y == z ]) r - -reflexiveClosure :: Eq a => [a] -- ^ The set over which the relation is defined. - -> [(a,a)] -> [(a,a)] -reflexiveClosure u r = [(x,x) | x <- u] `union` r - -symmetricSubrelation :: Eq a => [(a,a)] -> [(a,a)] -symmetricSubrelation r = [p | p@(x,y) <- r, (y,x) `elem` r] - --- | Get the equivalence classes from an equivalence relation. Since --- the relation is relexive, the set can be recoved from the relation. -equivalenceClasses :: Eq a => [(a,a)] -> [[a]] -equivalenceClasses r = equivalenceClasses_ (nub (map fst r)) r - where equivalenceClasses_ [] _ = [] - equivalenceClasses_ (x:xs) r = (x:ys):equivalenceClasses_ zs r - where (ys,zs) = partition (isRelatedTo r x) xs -- -- * Utilities -- +findSet :: Eq c => c -> [[c]] -> Maybe [c] +findSet x = find (x `elem`) + fix :: Eq a => (a -> a) -> a -> a fix f x = let x' = f x in if x' == x then x else fix f x' @@ -240,26 +150,12 @@ nothingOrNull :: Maybe [a] -> Bool nothingOrNull Nothing = True nothingOrNull (Just xs) = null xs -safeInit :: [a] -> [a] -safeInit [] = [] -safeInit xs = init xs - unionAll :: Eq a => [[a]] -> [a] unionAll = nub . concat whenMP :: MonadPlus m => Bool -> a -> m a whenMP b x = if b then return x else mzero --- --- * Testing stuff, can be removed --- +lookup' :: Eq a => a -> [(a,b)] -> b +lookup' x = fromJust . lookup x -c --> ss = CFRule c ss (mkName "") - -prGr g = putStrLn $ showGr g - -showGr g = unlines $ map showRule g - -showRule (CFRule c ss _) = c ++ " --> " ++ unwords (map showSym ss) - -showSym s = symbol id show s \ No newline at end of file diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index c952bcd5c..2c6b26a95 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/04 11:45:38 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.70 $ +-- > CVS $Date: 2005/09/12 15:46:44 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.71 $ -- -- A database for customizable GF shell commands. -- @@ -57,7 +57,7 @@ import GF.Canon.MkGFC import GF.CF.CFtoSRG import GF.Speech.PrGSL (gslPrinter) import GF.Speech.PrJSGF (jsgfPrinter) -import GF.Speech.PrSLF (slfPrinter) +import GF.Speech.PrSLF (slfPrinter,slfGraphvizPrinter,faGraphvizPrinter) import GF.Data.Zipper @@ -241,6 +241,12 @@ customGrammarPrinter = ,(strCI "slf", \s -> let opts = stateOptions s name = cncId s in slfPrinter name opts $ stateCFG s) + ,(strCI "slf_graphviz", \s -> let opts = stateOptions s + name = cncId s + in slfGraphvizPrinter name opts $ stateCFG s) + ,(strCI "fa_graphviz", \s -> let opts = stateOptions s + name = cncId s + in faGraphvizPrinter name opts $ stateCFG s) ,(strCI "plbnf", prLBNF True) ,(strCI "lbnf", prLBNF False) ,(strCI "bnf", prBNF False)