From a4e731cc33c3a8ccb6cdb1929f6b515720a1525e Mon Sep 17 00:00:00 2001 From: bjorn Date: Thu, 27 Nov 2008 08:43:08 +0000 Subject: Move Graph, Relation and Graphviz modules from GF.Speech to GF.Data. --- src/GF/Data/Graph.hs | 178 +++++++++++++++++++++++++++++++++++++++++++ src/GF/Data/Graphviz.hs | 116 ++++++++++++++++++++++++++++ src/GF/Data/Relation.hs | 130 +++++++++++++++++++++++++++++++ src/GF/Speech/CFG.hs | 2 +- src/GF/Speech/CFGToFA.hs | 4 +- src/GF/Speech/FiniteState.hs | 4 +- src/GF/Speech/Graph.hs | 178 ------------------------------------------- src/GF/Speech/Graphviz.hs | 116 ---------------------------- src/GF/Speech/Relation.hs | 130 ------------------------------- src/GF/Speech/SLF.hs | 2 +- src/GF/Speech/SRG.hs | 2 +- 11 files changed, 431 insertions(+), 431 deletions(-) create mode 100644 src/GF/Data/Graph.hs create mode 100644 src/GF/Data/Graphviz.hs create mode 100644 src/GF/Data/Relation.hs delete mode 100644 src/GF/Speech/Graph.hs delete mode 100644 src/GF/Speech/Graphviz.hs delete mode 100644 src/GF/Speech/Relation.hs (limited to 'src') diff --git a/src/GF/Data/Graph.hs b/src/GF/Data/Graph.hs new file mode 100644 index 000000000..bfb289860 --- /dev/null +++ b/src/GF/Data/Graph.hs @@ -0,0 +1,178 @@ +---------------------------------------------------------------------- +-- | +-- 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.Data.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/Data/Graphviz.hs b/src/GF/Data/Graphviz.hs new file mode 100644 index 000000000..411f76898 --- /dev/null +++ b/src/GF/Data/Graphviz.hs @@ -0,0 +1,116 @@ +---------------------------------------------------------------------- +-- | +-- 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.Data.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/Data/Relation.hs b/src/GF/Data/Relation.hs new file mode 100644 index 000000000..1a052ec68 --- /dev/null +++ b/src/GF/Data/Relation.hs @@ -0,0 +1,130 @@ +---------------------------------------------------------------------- +-- | +-- 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.Data.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/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 -- cgit v1.2.3