forked from GitHub/gf-core
Move Graph, Relation and Graphviz modules from GF.Speech to GF.Data.
This commit is contained in:
bjorn
178
src/GF/Data/Graph.hs
Normal file
178
src/GF/Data/Graph.hs
Normal file
@@ -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
|
||||
116
src/GF/Data/Graphviz.hs
Normal file
116
src/GF/Data/Graphviz.hs
Normal file
@@ -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
|
||||
130
src/GF/Data/Relation.hs
Normal file
130
src/GF/Data/Relation.hs
Normal file
@@ -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)
|
||||
Reference in New Issue
Block a user