Move Graph, Relation and Graphviz modules from GF.Speech to GF.Data.

8 files changed, 7 insertions, 431 deletions

diff --git a/src/GF/Speech/CFG.hs b/src/GF/Speech/CFG.hs
index 254024f5c..7f00d87ad 100644
--- a/src/GF/Speech/CFG.hs
+++ b/src/GF/Speech/CFG.hs
@@ -10,7 +10,7 @@ import GF.Data.Utilities
 import PGF.CId
 import GF.Infra.Option
 import GF.Infra.PrintClass
-import GF.Speech.Relation
+import GF.Data.Relation
 
 import Control.Monad
 import Control.Monad.State (State, get, put, evalState)
diff --git a/src/GF/Speech/CFGToFA.hs b/src/GF/Speech/CFGToFA.hs
index 1ac4bd24e..3045ac842 100644
--- a/src/GF/Speech/CFGToFA.hs
+++ b/src/GF/Speech/CFGToFA.hs
@@ -21,9 +21,9 @@ import GF.Speech.CFG
 import GF.Speech.PGFToCFG
 import GF.Infra.Ident (Ident)
 
+import GF.Data.Graph
+import GF.Data.Relation
 import GF.Speech.FiniteState
-import GF.Speech.Graph
-import GF.Speech.Relation
 import GF.Speech.CFG
 
 data Recursivity = RightR | LeftR | NotR
diff --git a/src/GF/Speech/FiniteState.hs b/src/GF/Speech/FiniteState.hs
index c809eb544..136d773a2 100644
--- a/src/GF/Speech/FiniteState.hs
+++ b/src/GF/Speech/FiniteState.hs
@@ -42,8 +42,8 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 
 import GF.Data.Utilities
-import GF.Speech.Graph
-import qualified GF.Speech.Graphviz as Dot
+import GF.Data.Graph
+import qualified GF.Data.Graphviz as Dot
 
 type State = Int
 
diff --git a/src/GF/Speech/Graph.hs b/src/GF/Speech/Graph.hs
deleted file mode 100644
index 1a0ebe0c0..000000000
--- a/src/GF/Speech/Graph.hs
+++ /dev/null
@@ -1,178 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : Graph
--- Maintainer  : BB
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/11/10 16:43:44 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.2 $
---
--- A simple graph module.
------------------------------------------------------------------------------
-module GF.Speech.Graph ( Graph(..), Node, Edge, NodeInfo
-                        , newGraph, nodes, edges
-                        , nmap, emap, newNode, newNodes, newEdge, newEdges
-                        , insertEdgeWith
-                        , removeNode, removeNodes
-                        , nodeInfo
-                        , getIncoming, getOutgoing, getNodeLabel
-                        , inDegree, outDegree
-                        , nodeLabel
-                        , edgeFrom, edgeTo, edgeLabel
-                        , reverseGraph, mergeGraphs, renameNodes
-                       ) where
-
-import GF.Data.Utilities
-
-import Data.List
-import Data.Maybe
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
-		 deriving (Eq,Show)
-
-type Node n a = (n,a)
-type Edge n b = (n,n,b)
-
-type NodeInfo n a b = Map n (a, [Edge n b], [Edge n b])
-
--- | Create a new empty graph.
-newGraph :: [n] -> Graph n a b
-newGraph ns = Graph ns [] []
-
--- | Get all the nodes in the graph.
-nodes :: Graph n a b -> [Node n a]
-nodes (Graph _ ns _) = ns
-
--- | Get all the edges in the graph.
-edges :: Graph n a b -> [Edge n b]
-edges (Graph _ _ es) = es
-
--- | Map a function over the node labels.
-nmap :: (a -> c) -> Graph n a b -> Graph n c b
-nmap f (Graph c ns es) = Graph c [(n,f l) | (n,l) <- ns] es
-
--- | Map a function over the edge labels.
-emap :: (b -> c) -> Graph n a b -> Graph n a c
-emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
-
--- | Add a node to the graph.
-newNode :: a               -- ^ Node label
-        -> Graph n a b 
-        -> (Graph n a b,n) -- ^ Node graph and name of new node
-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 g = (g', zip ns ls)
-  where (g',ns) = mapAccumL (flip newNode) g ls
--- lazy version:
---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)
-
-newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
-newEdges es g = foldl' (flip newEdge) g es
--- lazy version:
--- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
-
-insertEdgeWith :: Eq n => 
-                  (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
-insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
-  where h [] = [e]
-        h (e'@(x',y',l'):es') | x' == x && y' == y = (x',y', f l l'):es'
-                              | otherwise = e':h es'
-
--- | Remove a node and all edges to and from that node.
-removeNode :: Ord n => n -> Graph n a b -> Graph n a b
-removeNode n = removeNodes (Set.singleton n)
-
--- | Remove a set of nodes and all edges to and from those nodes.
-removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
-removeNodes xs (Graph c ns es) = Graph c ns' es'
-  where 
-  keepNode n = not (Set.member n xs)
-  ns' = [ x | x@(n,_) <- ns, keepNode n ]
-  es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
-
--- | Get a map of node names to info about each node.
-nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
-nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
-  where 
-  inc = groupEdgesBy edgeTo g
-  out = groupEdgesBy edgeFrom g
-  fn m n = fromMaybe [] (Map.lookup n m)
-
-groupEdgesBy :: (Ord n) => (Edge n b -> n) -- ^ Gets the node to group by
-             -> Graph n a b -> Map n [Edge n b]
-groupEdgesBy f g = Map.fromListWith (++) [(f e, [e]) | e <- edges g]
-
-lookupNode :: Ord n => NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
-lookupNode i n = fromJust $ Map.lookup n i
-
-getIncoming :: Ord n => NodeInfo n a b -> n -> [Edge n b]
-getIncoming i n = let (_,inc,_) = lookupNode i n in inc
-
-getOutgoing :: Ord n => NodeInfo n a b -> n -> [Edge n b]
-getOutgoing i n = let (_,_,out) = lookupNode i n in out
-
-inDegree :: Ord n => NodeInfo n a b -> n -> Int
-inDegree i n = length $ getIncoming i n
-
-outDegree :: Ord n => NodeInfo n a b -> n -> Int
-outDegree i n = length $ getOutgoing i n
-
-getNodeLabel :: Ord n => NodeInfo n a b -> n -> a
-getNodeLabel i n = let (l,_,_) = lookupNode i n in l
-
-nodeLabel :: Node n a -> a
-nodeLabel = snd
-
-edgeFrom :: Edge n b -> n
-edgeFrom (f,_,_) = f
-
-edgeTo :: Edge n b -> n
-edgeTo (_,t,_) = t
-
-edgeLabel :: Edge n b -> b
-edgeLabel (_,_,l) = l
-
-reverseGraph :: Graph n a b -> Graph n a b
-reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
-
--- | Add the nodes from the second graph to the first graph.
---   The nodes in the second graph will be renamed using the name 
---   supply in the first graph.
---   This function is more efficient when the second graph
---   is smaller than the first.
-mergeGraphs :: Ord m => Graph n a b -> Graph m a b 
-            -> (Graph n a b, m -> n) -- ^ The new graph and a function translating
-                                      --  the old names of nodes in the second graph
-                                      --  to names in the new graph.
-mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
-  where 
-  (xs,c') = splitAt (length (nodes g2)) c
-  newNames = Map.fromList (zip (map fst (nodes g2)) xs)
-  newName n = fromJust $ Map.lookup n newNames
-  Graph _ ns2 es2 = renameNodes newName undefined g2
-
--- | Rename the nodes in the graph.
-renameNodes :: (n -> m) -- ^ renaming function
-            -> [m] -- ^ infinite supply of fresh node names, to
-                   --   use when adding nodes in the future.
-            -> Graph n a b -> Graph m a b
-renameNodes newName c (Graph _ ns es) = Graph c ns' es'
-    where ns' = map' (\ (n,x) -> (newName n,x)) ns
-	  es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
-
--- | A strict 'map'
-map' :: (a -> b) -> [a] -> [b]
-map' _ [] = []
-map' f (x:xs) = ((:) $! f x) $! map' f xs
diff --git a/src/GF/Speech/Graphviz.hs b/src/GF/Speech/Graphviz.hs
deleted file mode 100644
index 1851fcb64..000000000
--- a/src/GF/Speech/Graphviz.hs
+++ /dev/null
@@ -1,116 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : Graphviz
--- Maintainer  : BB
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/09/15 18:10:44 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.2 $
---
--- Graphviz DOT format representation and printing.
------------------------------------------------------------------------------
-
-module GF.Speech.Graphviz (
-				  Graph(..), GraphType(..), 
-				  Node(..), Edge(..),
-				  Attr,
-                                  addSubGraphs,
-                                  setName,
-                                  setAttr,
-				  prGraphviz
-			) where
-
-import Data.Char
-
-import GF.Data.Utilities
-
--- | Graph type, graph ID, graph attirbutes, graph nodes, graph edges, subgraphs
-data Graph = Graph {
-                    gType :: GraphType,
-                    gId :: Maybe String,
-                    gAttrs :: [Attr],
-                    gNodes :: [Node],
-                    gEdges :: [Edge],
-                    gSubgraphs :: [Graph]
-                   }
-  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)
-
---
--- * Graph construction
---
-
-addSubGraphs :: [Graph] -> Graph -> Graph
-addSubGraphs gs g = g { gSubgraphs = gs ++ gSubgraphs g }
-
-setName :: String -> Graph -> Graph
-setName n g = g { gId = Just n }
-
-setAttr :: String -> String -> Graph -> Graph
-setAttr n v g = g { gAttrs = tableSet n v (gAttrs g) }
-
---
--- * Pretty-printing
---
-
-prGraphviz :: Graph -> String
-prGraphviz g@(Graph t i _ _ _ _) =
-    graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
-
-prSubGraph :: Graph -> String
-prSubGraph g@(Graph _ i _ _ _ _) = 
-    "subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
-
-prGraph :: Graph -> String
-prGraph (Graph t id at ns es ss) = 
-    unlines $ map (++";") (map prAttr at
-		           ++ map prNode ns 
-		           ++ map (prEdge t) es
-                           ++ map prSubGraph ss)
-
-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 ++ " " ++ esc y ++ " " ++ prAttrList at
-
-edgeop :: GraphType -> String
-edgeop Directed = "->"
-edgeop Undirected = "--"
-
-prAttrList :: [Attr] -> String
-prAttrList [] = ""
-prAttrList at =	"[" ++ join "," (map prAttr at) ++ "]"
-
-prAttr :: Attr -> String
-prAttr (n,v) = esc n ++ " = " ++ esc v
-
-esc :: String -> String
-esc s | needEsc s = "\"" ++ concat [ if shouldEsc c then ['\\',c] else [c] | c <- s ] ++ "\""
-      | otherwise = s
-  where shouldEsc = (`elem` ['"', '\\'])
-
-needEsc :: String -> Bool
-needEsc [] = True
-needEsc xs | all isDigit xs = False
-needEsc (x:xs) = not (isIDFirst x && all isIDChar xs)
-
-isIDFirst, isIDChar :: Char -> Bool
-isIDFirst c = c `elem` (['_']++['a'..'z']++['A'..'Z'])
-isIDChar c = isIDFirst c || isDigit c
diff --git a/src/GF/Speech/Relation.hs b/src/GF/Speech/Relation.hs
deleted file mode 100644
index 641d671a9..000000000
--- a/src/GF/Speech/Relation.hs
+++ /dev/null
@@ -1,130 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : Relation
--- Maintainer  : BB
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/26 17:13:13 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.1 $
---
--- A simple module for relations.
------------------------------------------------------------------------------
-
-module GF.Speech.Relation (Rel, mkRel, mkRel'
-                           , allRelated , isRelatedTo
-                           , transitiveClosure
-                           , reflexiveClosure, reflexiveClosure_
-                           , symmetricClosure
-                           , symmetricSubrelation, reflexiveSubrelation
-                           , reflexiveElements
-                           , equivalenceClasses
-                           , isTransitive, isReflexive, isSymmetric
-                           , isEquivalence
-                           , isSubRelationOf) where
-
-import Data.List
-import Data.Maybe
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-import GF.Data.Utilities
-
-type Rel a = Map a (Set a)
-
--- | Creates a relation from a list of related pairs.
-mkRel :: Ord a => [(a,a)] -> Rel a
-mkRel ps = relates ps Map.empty
-
--- | Creates a relation from a list pairs of elements and the elements
---   related to them.
-mkRel' :: Ord a => [(a,[a])] -> Rel a
-mkRel' xs = Map.fromListWith Set.union [(x,Set.fromList ys) | (x,ys) <- xs]
-
-relToList :: Rel a -> [(a,a)]
-relToList r = [ (x,y) | (x,ys) <- Map.toList r, y <- Set.toList ys ]
-
--- | Add a pair to the relation.
-relate :: Ord a => a -> a -> Rel a -> Rel a
-relate x y r = Map.insertWith Set.union x (Set.singleton y) r
-
--- | Add a list of pairs to the relation.
-relates :: Ord a => [(a,a)] -> Rel a -> Rel a
-relates ps r = foldl (\r' (x,y) -> relate x y r') r ps
-
--- | Checks if an element is related to another.
-isRelatedTo :: Ord a => Rel a -> a  -> a -> Bool
-isRelatedTo r x y = maybe False (y `Set.member`) (Map.lookup x r)
-
--- | Get the set of elements to which a given element is related.
-allRelated :: Ord a => Rel a -> a -> Set a
-allRelated r x = fromMaybe Set.empty (Map.lookup x r)
-
--- | Get all elements in the relation.
-domain :: Ord a => Rel a -> Set a
-domain r = foldl Set.union (Map.keysSet r) (Map.elems r)
-
--- | Keep only pairs for which both elements are in the given set.
-intersectSetRel :: Ord a => Set a -> Rel a -> Rel a
-intersectSetRel s = filterRel (\x y -> x `Set.member` s && y `Set.member` s)
-
-transitiveClosure :: Ord a => Rel a -> Rel a
-transitiveClosure r = fix (Map.map growSet) r
-  where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
-
-reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
-		 -> Rel a -> Rel a
-reflexiveClosure_ u r = relates [(x,x) | x <- u] r
-
--- | Uses 'domain'
-reflexiveClosure :: Ord a => Rel a -> Rel a
-reflexiveClosure r = reflexiveClosure_ (Set.toList $ domain r) r
-
-symmetricClosure :: Ord a => Rel a -> Rel a
-symmetricClosure r = relates [ (y,x) | (x,y) <- relToList r ] r
-
-symmetricSubrelation :: Ord a => Rel a -> Rel a
-symmetricSubrelation r = filterRel (flip $ isRelatedTo r) r
-
-reflexiveSubrelation :: Ord a => Rel a -> Rel a
-reflexiveSubrelation r = intersectSetRel (reflexiveElements r) r
-
--- | Get the set of elements which are related to themselves.
-reflexiveElements :: Ord a => Rel a -> Set a
-reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
-
--- | Keep the related pairs for which the predicate is true.
-filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a 
-filterRel p = purgeEmpty . Map.mapWithKey (Set.filter . p)
-
--- | Remove keys that map to no elements.
-purgeEmpty :: Ord a => Rel a -> Rel a
-purgeEmpty r = Map.filter (not . Set.null) r
-
-
--- | Get the equivalence classes from an equivalence relation. 
-equivalenceClasses :: Ord a => Rel a -> [Set a]
-equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
- where equivalenceClasses_ [] _ = []
-       equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
-	   where ys = allRelated r x
-                 zs = [x' | x' <- xs, not (x' `Set.member` ys)]
-
-isTransitive :: Ord a => Rel a -> Bool
-isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r, 
-                      y <- Set.toList ys, z <- Set.toList (allRelated r y)]
-
-isReflexive :: Ord a => Rel a -> Bool
-isReflexive r = all (\ (x,ys) -> x `Set.member` ys) (Map.toList r)
-
-isSymmetric :: Ord a => Rel a -> Bool
-isSymmetric r = and [isRelatedTo r y x | (x,y) <- relToList r]
-
-isEquivalence :: Ord a => Rel a -> Bool
-isEquivalence r = isReflexive r && isSymmetric r && isTransitive r
-
-isSubRelationOf :: Ord a => Rel a -> Rel a -> Bool
-isSubRelationOf r1 r2 = all (uncurry (isRelatedTo r2)) (relToList r1)
diff --git a/src/GF/Speech/SLF.hs b/src/GF/Speech/SLF.hs
index 4bdc05212..84633149b 100644
--- a/src/GF/Speech/SLF.hs
+++ b/src/GF/Speech/SLF.hs
@@ -18,7 +18,7 @@ import GF.Speech.FiniteState
 import GF.Speech.CFG
 import GF.Speech.CFGToFA
 import GF.Speech.PGFToCFG
-import qualified GF.Speech.Graphviz as Dot
+import qualified GF.Data.Graphviz as Dot
 import PGF
 import PGF.CId
 
diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs
index 03f6c0be7..1baa126f1 100644
--- a/src/GF/Speech/SRG.hs
+++ b/src/GF/Speech/SRG.hs
@@ -25,7 +25,7 @@ import GF.Infra.Option
 import GF.Infra.PrintClass
 import GF.Speech.CFG
 import GF.Speech.PGFToCFG
-import GF.Speech.Relation
+import GF.Data.Relation
 import GF.Speech.FiniteState
 import GF.Speech.RegExp
 import GF.Speech.CFGToFA