diff options
| -rw-r--r-- | src/GF/Data/Utilities.hs | 88 | ||||
| -rw-r--r-- | src/GF/Speech/CFGToFiniteState.hs | 15 | ||||
| -rw-r--r-- | src/GF/Speech/FiniteState.hs | 38 | ||||
| -rw-r--r-- | src/GF/Speech/PrGSL.hs | 5 | ||||
| -rw-r--r-- | src/GF/Speech/PrJSGF.hs | 13 | ||||
| -rw-r--r-- | src/GF/Speech/PrSLF.hs | 25 | ||||
| -rw-r--r-- | src/GF/Speech/SRG.hs | 32 | ||||
| -rw-r--r-- | src/GF/Speech/TransformCFG.hs | 35 | ||||
| -rw-r--r-- | src/GF/Visualization/Graphviz.hs | 68 | ||||
| -rw-r--r-- | src/GF/Visualization/VisualizeGrammar.hs | 8 | ||||
| -rw-r--r-- | src/GF/Visualization/VisualizeTree.hs | 2 |
11 files changed, 214 insertions, 115 deletions
diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs index 356bf4d1a..f32e43af3 100644 --- a/src/GF/Data/Utilities.hs +++ b/src/GF/Data/Utilities.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.2 $ +-- > CVS $Date: 2005/09/14 15:17:29 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.3 $ -- -- Basic functions not in the standard libraries ----------------------------------------------------------------------------- @@ -14,7 +14,9 @@ module GF.Data.Utilities where -import Monad (liftM) +import Data.Maybe +import Data.List +import Control.Monad (MonadPlus(..),liftM) -- * functions on lists @@ -32,6 +34,11 @@ 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 @@ -60,6 +67,24 @@ updateNthM :: Monad m => (a -> m a) -> Int -> [a] -> m [a] updateNthM update 0 (a : as) = liftM (:as) (update a) updateNthM update n (a : as) = liftM (a:) (updateNthM update (n-1) as) +-- | Like 'init', but returns the empty list when the input is empty. +safeInit :: [a] -> [a] +safeInit [] = [] +safeInit xs = init xs + +-- | Like 'nub', but more efficient as it uses sorting internally. +sortNub :: Ord a => [a] -> [a] +sortNub = map head . group . sort + +-- | Take the union of a list of lists. +unionAll :: Eq a => [[a]] -> [a] +unionAll = nub . concat + +-- | Like lookup, but fails if the argument is not found, +-- instead of returning Nothing. +lookup' :: Eq a => a -> [(a,b)] -> b +lookup' x = fromJust . lookup x + -- * functions on pairs mapFst :: (a -> a') -> (a, b) -> (a', b) @@ -68,4 +93,59 @@ mapFst f (a, b) = (f a, b) mapSnd :: (b -> b') -> (a, b) -> (a, b') mapSnd f (a, b) = (a, f b) +-- * functions on monads + +-- | Return the given value if the boolean is true, els return 'mzero'. +whenMP :: MonadPlus m => Bool -> a -> m a +whenMP b x = if b then return x else mzero + +-- * functions on Maybes + +-- | Returns true if the argument is Nothing or Just [] +nothingOrNull :: Maybe [a] -> Bool +nothingOrNull = maybe True null + +-- * functions on functions + +-- | Apply all the functions in the list to the argument. +foldFuns :: [a -> a] -> a -> a +foldFuns fs x = foldl (flip ($)) x fs + +-- | Fixpoint iteration. +fix :: Eq a => (a -> a) -> a -> a +fix f x = let x' = f x in if x' == x then x else fix f x' + +-- * functions on strings + +-- | Join a number of lists by using the given glue +-- between the lists. +join :: [a] -- ^ glue + -> [[a]] -- ^ lists to join + -> [a] +join g = concat . intersperse g + +-- * ShowS-functions + +nl :: ShowS +nl = showChar '\n' + +sp :: ShowS +sp = showChar ' ' + +wrap :: String -> ShowS -> String -> ShowS +wrap o s c = showString o . s . showString c + +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +unwordsS :: [ShowS] -> ShowS +unwordsS = joinS " " + +unlinesS :: [ShowS] -> ShowS +unlinesS = joinS "\n" + +joinS :: String -> [ShowS] -> ShowS +joinS glue = concatS . intersperse (showString glue) + + diff --git a/src/GF/Speech/CFGToFiniteState.hs b/src/GF/Speech/CFGToFiniteState.hs index 444f4bb6e..1816e4502 100644 --- a/src/GF/Speech/CFGToFiniteState.hs +++ b/src/GF/Speech/CFGToFiniteState.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/12 16:10:23 $ +-- > CVS $Date: 2005/09/14 15:17:29 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.2 $ +-- > CVS $Revision: 1.3 $ -- -- Approximates CFGs with finite state networks. ----------------------------------------------------------------------------- @@ -16,6 +16,7 @@ module GF.Speech.CFGToFiniteState (cfgToFA, makeSimpleRegular) where import Data.List +import GF.Data.Utilities import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, NameProfile(..)) import GF.Conversion.Types @@ -160,13 +161,3 @@ equivalenceClasses r = equivalenceClasses_ (nub (map fst r)) r 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 = foldl (flip ($)) 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 100335a2d..374732426 100644 --- a/src/GF/Speech/FiniteState.hs +++ b/src/GF/Speech/FiniteState.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/12 22:32:24 $ +-- > CVS $Date: 2005/09/14 15:17:29 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ +-- > CVS $Revision: 1.7 $ -- -- A simple finite state network module. ----------------------------------------------------------------------------- @@ -19,12 +19,14 @@ module GF.Speech.FiniteState (FA, State, newState, newTransition, mapStates, mapTransitions, moveLabelsToNodes, minimize, - prGraphGraphviz) where + prFAGraphviz) where import Data.List import Data.Maybe (fromJust) -import Debug.Trace +import GF.Data.Utilities +import qualified GF.Visualization.Graphviz as Dot + data FA a b = FA (Graph a b) State [State] @@ -75,14 +77,15 @@ minimize = onGraph mimimizeGr1 moveLabelsToNodes :: Eq a => FA () (Maybe a) -> FA (Maybe a) () moveLabelsToNodes = onGraph moveLabelsToNodes_ -prGraphGraphviz :: FA String String -> String -prGraphGraphviz (FA (Graph _ ns es) _ _) = - "digraph {\n" ++ unlines (map prNode ns) - ++ "\n" - ++ unlines (map prEdge es) - ++ "\n}\n" - where prNode (n,l) = show n ++ " [label = " ++ show l ++ "]" - prEdge (f,t,l) = show f ++ " -> " ++ show t ++ " [label = " ++ show l ++ "]" +prFAGraphviz :: FA String String -> String +prFAGraphviz = Dot.prGraphviz . mkGraphviz + where + mkGraphviz (FA (Graph _ ns es) s f) = Dot.Graph Dot.Directed [] (map mkNode ns) (map mkEdge es) + where mkNode (n,l) = Dot.Node (show n) attrs + where attrs = [("label",l)] + ++ if n == s then [("shape","box")] else [] + ++ if n `elem` f then [("style","bold")] else [] + mkEdge (x,y,l) = Dot.Edge (show x) (show y) [("label",l)] -- -- * Graphs @@ -165,12 +168,5 @@ mimimizeGr2 = id removeDuplicateEdges :: Ord b => Graph a b -> Graph a b removeDuplicateEdges (Graph c ns es) = Graph c ns (sortNub es) - - - --- --- * Utilities --- - -sortNub :: Ord a => [a] -> [a] -sortNub = map head . group . sort
\ No newline at end of file +reverseGraph :: Graph a b -> Graph a b +reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ] diff --git a/src/GF/Speech/PrGSL.hs b/src/GF/Speech/PrGSL.hs index b98339914..4f245a328 100644 --- a/src/GF/Speech/PrGSL.hs +++ b/src/GF/Speech/PrGSL.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/07 14:21:30 $ +-- > CVS $Date: 2005/09/14 15:17:29 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.20 $ +-- > CVS $Revision: 1.21 $ -- -- This module prints a CFG as a Nuance GSL 2.0 grammar. -- @@ -17,6 +17,7 @@ module GF.Speech.PrGSL (gslPrinter) where +import GF.Data.Utilities import GF.Speech.SRG import GF.Infra.Ident diff --git a/src/GF/Speech/PrJSGF.hs b/src/GF/Speech/PrJSGF.hs index 052299329..5d0b0a211 100644 --- a/src/GF/Speech/PrJSGF.hs +++ b/src/GF/Speech/PrJSGF.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/09/07 14:21:30 $ +-- > CVS $Date: 2005/09/14 15:17:29 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.14 $ +-- > CVS $Revision: 1.15 $ -- -- This module prints a CFG as a JSGF grammar. -- @@ -19,13 +19,14 @@ module GF.Speech.PrJSGF (jsgfPrinter) where -import GF.Speech.SRG -import GF.Infra.Ident +import GF.Conversion.Types +import GF.Data.Utilities import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..)) -import GF.Conversion.Types +import GF.Infra.Ident import GF.Infra.Print import GF.Infra.Option +import GF.Speech.SRG jsgfPrinter :: Ident -- ^ Grammar name -> Options -> CGrammar -> String @@ -45,7 +46,7 @@ prJSGF (SRG{grammarName=name,startCat=start,origStartCat=origStart,rules=rs}) . showString "public <MAIN> = " . prCat start . showChar ';' . nl . nl prRule (SRGRule cat origCat rhs) = comments [origCat] . nl - . prCat cat . showString " = " . join " | " (map prAlt rhs) . nl + . prCat cat . showString " = " . joinS " | " (map prAlt rhs) . nl prAlt rhs | null rhs' = showString "<NULL>" | otherwise = wrap "(" (unwordsS (map prSymbol rhs')) ")" where rhs' = rmPunct rhs diff --git a/src/GF/Speech/PrSLF.hs b/src/GF/Speech/PrSLF.hs index 720e66c56..fac25ed77 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/13 08:20:20 $ +-- > CVS $Date: 2005/09/14 15:17:30 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ +-- > CVS $Revision: 1.9 $ -- -- This module converts a CFG to an SLF finite-state network -- for use with the ATK recognizer. The SLF format is described @@ -21,17 +21,17 @@ module GF.Speech.PrSLF (slfPrinter,slfGraphvizPrinter, faGraphvizPrinter,regularPrinter) where -import GF.Speech.SRG -import GF.Speech.TransformCFG -import GF.Speech.CFGToFiniteState -import GF.Speech.FiniteState -import GF.Infra.Ident - +import GF.Data.Utilities +import GF.Conversion.Types import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..),symbol) -import GF.Conversion.Types -import GF.Infra.Print +import GF.Infra.Ident import GF.Infra.Option +import GF.Infra.Print +import GF.Speech.CFGToFiniteState +import GF.Speech.FiniteState +import GF.Speech.SRG +import GF.Speech.TransformCFG import Data.Char (toUpper,toLower) import Data.List @@ -54,12 +54,13 @@ slfPrinter name opts cfg = prSLF (automatonToSLF $ moveLabelsToNodes $ cfgToFA n slfGraphvizPrinter :: Ident -- ^ Grammar name -> Options -> CGrammar -> String slfGraphvizPrinter name opts cfg = - prGraphGraphviz (mapStates (fromMaybe "") $ mapTransitions (const "") $ moveLabelsToNodes $ cfgToFA name opts cfg) + prFAGraphviz (mapStates (fromMaybe "") $ mapTransitions (const "") $ moveLabelsToNodes $ cfgToFA name opts cfg) faGraphvizPrinter :: Ident -- ^ Grammar name -> Options -> CGrammar -> String faGraphvizPrinter name opts cfg = - prGraphGraphviz (mapStates (const "") $ mapTransitions (fromMaybe "") $ cfgToFA name opts cfg) + prFAGraphviz (mapStates (const "") $ mapTransitions (fromMaybe "") $ cfgToFA name opts cfg) + -- | Convert the grammar to a regular grammar and print it in BNF regularPrinter :: CGrammar -> String diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs index 6d88a677e..24f2e868d 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/12 15:46:44 $ +-- > CVS $Date: 2005/09/14 15:17:30 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.16 $ +-- > CVS $Revision: 1.17 $ -- -- Representation of, conversion to, and utilities for -- printing of a general Speech Recognition Grammar. @@ -20,6 +20,7 @@ module GF.Speech.SRG where +import GF.Data.Utilities import GF.Infra.Ident import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..)) @@ -80,29 +81,8 @@ mkCatNames prefix origNames = listToFM (zip origNames names) -- * Utilities for building and printing SRGs -- -nl :: ShowS -nl = showChar '\n' - -sp :: ShowS -sp = showChar ' ' - -wrap :: String -> ShowS -> String -> ShowS -wrap o s c = showString o . s . showString c - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -unwordsS :: [ShowS] -> ShowS -unwordsS = join " " - -unlinesS :: [ShowS] -> ShowS -unlinesS = join "\n" - -join :: String -> [ShowS] -> ShowS -join glue = concatS . intersperse (showString glue) - -prtS :: Print a => a -> ShowS -prtS = showString . prt - lookupFM_ :: (Ord key, Show key) => FiniteMap key elt -> key -> elt lookupFM_ fm k = lookupWithDefaultFM fm (error $ "Key not found: " ++ show k) k + +prtS :: Print a => a -> ShowS +prtS = showString . prt
\ No newline at end of file diff --git a/src/GF/Speech/TransformCFG.hs b/src/GF/Speech/TransformCFG.hs index a32da82fe..84feae845 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/12 16:10:23 $ +-- > CVS $Date: 2005/09/14 15:17:30 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.21 $ +-- > CVS $Revision: 1.22 $ -- -- This module does some useful transformations on CFGs. -- @@ -23,12 +23,13 @@ module GF.Speech.TransformCFG {- (CFRule_, CFRules, removeLeftRecursion, removeEmptyCats, removeIdenticalRules) -} where -import GF.Infra.Ident +import GF.Conversion.Types +import GF.Data.Utilities import GF.Formalism.CFG import GF.Formalism.Utilities (Symbol(..), mapSymbol, filterCats, symbol, NameProfile(..)) -import GF.Conversion.Types -import GF.Infra.Print +import GF.Infra.Ident import GF.Infra.Option +import GF.Infra.Print import GF.Speech.FiniteState import Control.Monad @@ -36,8 +37,6 @@ import Data.FiniteMap import Data.List import Data.Maybe (fromJust, fromMaybe) -import Debug.Trace - -- | not very nice to replace the structured CFCat type with a simple string type CFRule_ = CFRule Cat_ Name Token @@ -135,26 +134,4 @@ anyUsedBy cs (CFRule _ ss _) = any (`elem` cs) (filterCats ss) mkName :: String -> Name mkName n = Name (IC n) [] --- --- * 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' - -nothingOrNull :: Maybe [a] -> Bool -nothingOrNull Nothing = True -nothingOrNull (Just xs) = null 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 - -lookup' :: Eq a => a -> [(a,b)] -> b -lookup' x = fromJust . lookup x diff --git a/src/GF/Visualization/Graphviz.hs b/src/GF/Visualization/Graphviz.hs new file mode 100644 index 000000000..fe2dd0b82 --- /dev/null +++ b/src/GF/Visualization/Graphviz.hs @@ -0,0 +1,68 @@ +---------------------------------------------------------------------- +-- | +-- Module : Graphviz +-- Maintainer : BB +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/09/14 15:17:30 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.1 $ +-- +-- Graphviz DOT format representation and printing. +----------------------------------------------------------------------------- + +module GF.Visualization.Graphviz ( + Graph(..), GraphType(..), + Node(..), Edge(..), + Attr, + prGraphviz + ) where + +import GF.Data.Utilities + +data Graph = Graph GraphType [Attr] [Node] [Edge] + deriving (Show) + +data GraphType = Directed | Undirected + deriving (Show) + +data Node = Node String [Attr] + deriving Show + +data Edge = Edge String String [Attr] + deriving Show + +type Attr = (String,String) + +prGraphviz :: Graph -> String +prGraphviz (Graph t at ns es) = + unlines $ [graphtype t ++ " {"] + ++ map (++";") (map prAttr at + ++ map prNode ns + ++ map (prEdge t) es) + ++ ["}\n"] + +graphtype :: GraphType -> String +graphtype Directed = "digraph" +graphtype Undirected = "graph" + +prNode :: Node -> String +prNode (Node n at) = esc n ++ " " ++ prAttrList at + +prEdge :: GraphType -> Edge -> String +prEdge t (Edge x y at) = esc x ++ " " ++ edgeop t ++ " " ++ prAttrList at + +edgeop :: GraphType -> String +edgeop Directed = "->" +edgeop Undirected = "--" + +prAttrList :: [Attr] -> String +prAttrList = join "," . map prAttr + +prAttr :: Attr -> String +prAttr (n,v) = esc n ++ " = " ++ esc v + +esc :: String -> String +esc s = "\"" ++ concat [ if shouldEsc c then ['\\',c] else [c] | c <- s ] ++ "\"" + where shouldEsc = (`elem` ['"', '\\'])
\ No newline at end of file diff --git a/src/GF/Visualization/VisualizeGrammar.hs b/src/GF/Visualization/VisualizeGrammar.hs index e217dd7e2..b5446aec8 100644 --- a/src/GF/Visualization/VisualizeGrammar.hs +++ b/src/GF/Visualization/VisualizeGrammar.hs @@ -5,11 +5,13 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/05/17 11:20:26 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.9 $ +-- > CVS $Date: 2005/09/14 15:17:30 $ +-- > CVS $Author: bringert $ +-- > CVS $Revision: 1.10 $ -- -- Print a graph of module dependencies in Graphviz DOT format +-- FIXME: change this to use GF.Visualization.Graphviz, +-- instead of rolling its own. ----------------------------------------------------------------------------- module GF.Visualization.VisualizeGrammar ( visualizeCanonGrammar, diff --git a/src/GF/Visualization/VisualizeTree.hs b/src/GF/Visualization/VisualizeTree.hs index 8edc5f3b2..5fe740c12 100644 --- a/src/GF/Visualization/VisualizeTree.hs +++ b/src/GF/Visualization/VisualizeTree.hs @@ -11,6 +11,8 @@ -- -- Print a graph of an abstract syntax tree in Graphviz DOT format -- Based on BB's VisualizeGrammar +-- FIXME: change this to use GF.Visualization.Graphviz, +-- instead of rolling its own. ----------------------------------------------------------------------------- module GF.Visualization.VisualizeTree ( visualizeTrees |