Added Graphviz module for graphviz stuff. Move a lot of utility functions to GF.Data.Utilities.

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)
+
+
 

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

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
+reverseGraph :: Graph a b -> Graph a b
+reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]

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
 

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

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

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

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
 

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` ['"', '\\'])

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,

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