----------------------------------------------------------------------
-- |
-- 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 (Graph n a b -> Graph n a b -> Bool
(Graph n a b -> Graph n a b -> Bool)
-> (Graph n a b -> Graph n a b -> Bool) -> Eq (Graph n a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall n a b.
(Eq n, Eq a, Eq b) =>
Graph n a b -> Graph n a b -> Bool
/= :: Graph n a b -> Graph n a b -> Bool
$c/= :: forall n a b.
(Eq n, Eq a, Eq b) =>
Graph n a b -> Graph n a b -> Bool
== :: Graph n a b -> Graph n a b -> Bool
$c== :: forall n a b.
(Eq n, Eq a, Eq b) =>
Graph n a b -> Graph n a b -> Bool
Eq,Int -> Graph n a b -> ShowS
[Graph n a b] -> ShowS
Graph n a b -> String
(Int -> Graph n a b -> ShowS)
-> (Graph n a b -> String)
-> ([Graph n a b] -> ShowS)
-> Show (Graph n a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall n a b.
(Show n, Show a, Show b) =>
Int -> Graph n a b -> ShowS
forall n a b. (Show n, Show a, Show b) => [Graph n a b] -> ShowS
forall n a b. (Show n, Show a, Show b) => Graph n a b -> String
showList :: [Graph n a b] -> ShowS
$cshowList :: forall n a b. (Show n, Show a, Show b) => [Graph n a b] -> ShowS
show :: Graph n a b -> String
$cshow :: forall n a b. (Show n, Show a, Show b) => Graph n a b -> String
showsPrec :: Int -> Graph n a b -> ShowS
$cshowsPrec :: forall n a b.
(Show n, Show a, Show b) =>
Int -> Graph n a b -> ShowS
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 :: [n] -> Graph n a b
newGraph [n]
ns = [n] -> [Node n a] -> [Edge n b] -> Graph n a b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
ns [] []

-- | Get all the nodes in the graph.
nodes :: Graph n a b -> [Node n a]
nodes :: Graph n a b -> [Node n a]
nodes (Graph [n]
_ [Node n a]
ns [Edge n b]
_) = [Node n a]
ns

-- | Get all the edges in the graph.
edges :: Graph n a b -> [Edge n b]
edges :: Graph n a b -> [Edge n b]
edges (Graph [n]
_ [Node n a]
_ [Edge n b]
es) = [Edge n b]
es

-- | Map a function over the node labels.
nmap :: (a -> c) -> Graph n a b -> Graph n c b
nmap :: (a -> c) -> Graph n a b -> Graph n c b
nmap a -> c
f (Graph [n]
c [Node n a]
ns [Edge n b]
es) = [n] -> [Node n c] -> [Edge n b] -> Graph n c b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
c [(n
n,a -> c
f a
l) | (n
n,a
l) <- [Node n a]
ns] [Edge n b]
es

-- | Map a function over the edge labels.
emap :: (b -> c) -> Graph n a b -> Graph n a c
emap :: (b -> c) -> Graph n a b -> Graph n a c
emap b -> c
f (Graph [n]
c [Node n a]
ns [Edge n b]
es) = [n] -> [Node n a] -> [Edge n c] -> Graph n a c
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
c [Node n a]
ns [(n
x,n
y,b -> c
f b
l) | (n
x,n
y,b
l) <- [Edge n b]
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 :: a -> Graph n a b -> (Graph n a b, n)
newNode a
l (Graph (n
c:[n]
cs) [Node n a]
ns [Edge n b]
es) = ([n] -> [Node n a] -> [Edge n b] -> Graph n a b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
cs ((n
c,a
l)Node n a -> [Node n a] -> [Node n a]
forall a. a -> [a] -> [a]
:[Node n a]
ns) [Edge n b]
es, n
c)

newNodes :: [a] -> Graph n a b -> (Graph n a b,[Node n a])
newNodes :: [a] -> Graph n a b -> (Graph n a b, [Node n a])
newNodes [a]
ls Graph n a b
g = (Graph n a b
g', [n] -> [a] -> [Node n a]
forall a b. [a] -> [b] -> [(a, b)]
zip [n]
ns [a]
ls)
  where (Graph n a b
g',[n]
ns) = (Graph n a b -> a -> (Graph n a b, n))
-> Graph n a b -> [a] -> (Graph n a b, [n])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL ((a -> Graph n a b -> (Graph n a b, n))
-> Graph n a b -> a -> (Graph n a b, n)
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Graph n a b -> (Graph n a b, n)
forall a n b. a -> Graph n a b -> (Graph n a b, n)
newNode) Graph n a b
g [a]
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 :: Edge n b -> Graph n a b -> Graph n a b
newEdge Edge n b
e (Graph [n]
c [Node n a]
ns [Edge n b]
es) = [n] -> [Node n a] -> [Edge n b] -> Graph n a b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
c [Node n a]
ns (Edge n b
eEdge n b -> [Edge n b] -> [Edge n b]
forall a. a -> [a] -> [a]
:[Edge n b]
es)

newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
newEdges :: [Edge n b] -> Graph n a b -> Graph n a b
newEdges [Edge n b]
es Graph n a b
g = (Graph n a b -> Edge n b -> Graph n a b)
-> Graph n a b -> [Edge n b] -> Graph n a b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Edge n b -> Graph n a b -> Graph n a b)
-> Graph n a b -> Edge n b -> Graph n a b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Edge n b -> Graph n a b -> Graph n a b
forall n b a. Edge n b -> Graph n a b -> Graph n a b
newEdge) Graph n a b
g [Edge n b]
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 :: (b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
insertEdgeWith b -> b -> b
f e :: Edge n b
e@(n
x,n
y,b
l) (Graph [n]
c [Node n a]
ns [Edge n b]
es) = [n] -> [Node n a] -> [Edge n b] -> Graph n a b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
c [Node n a]
ns ([Edge n b] -> [Edge n b]
h [Edge n b]
es)
  where h :: [Edge n b] -> [Edge n b]
h [] = [Edge n b
e]
        h (e' :: Edge n b
e'@(n
x',n
y',b
l'):[Edge n b]
es') | n
x' n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
x Bool -> Bool -> Bool
&& n
y' n -> n -> Bool
forall a. Eq a => a -> a -> Bool
== n
y = (n
x',n
y', b -> b -> b
f b
l b
l')Edge n b -> [Edge n b] -> [Edge n b]
forall a. a -> [a] -> [a]
:[Edge n b]
es'
                              | Bool
otherwise = Edge n b
e'Edge n b -> [Edge n b] -> [Edge n b]
forall a. a -> [a] -> [a]
:[Edge n b] -> [Edge n b]
h [Edge n b]
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 -> Graph n a b -> Graph n a b
removeNode n
n = Set n -> Graph n a b -> Graph n a b
forall n a b. Ord n => Set n -> Graph n a b -> Graph n a b
removeNodes (n -> Set n
forall a. a -> Set a
Set.singleton n
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 :: Set n -> Graph n a b -> Graph n a b
removeNodes Set n
xs (Graph [n]
c [Node n a]
ns [Edge n b]
es) = [n] -> [Node n a] -> [Edge n b] -> Graph n a b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
c [Node n a]
ns' [Edge n b]
es'
  where
  keepNode :: n -> Bool
keepNode n
n = Bool -> Bool
not (n -> Set n -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member n
n Set n
xs)
  ns' :: [Node n a]
ns' = [ Node n a
x | x :: Node n a
x@(n
n,a
_) <- [Node n a]
ns, n -> Bool
keepNode n
n ]
  es' :: [Edge n b]
es' = [ Edge n b
e | e :: Edge n b
e@(n
f,n
t,b
_) <- [Edge n b]
es, n -> Bool
keepNode n
f Bool -> Bool -> Bool
&& n -> Bool
keepNode n
t ]

-- | Get a map of node names to info about each node.
nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
nodeInfo :: Graph n a b -> NodeInfo n a b
nodeInfo Graph n a b
g = [(n, (a, [Edge n b], [Edge n b]))] -> NodeInfo n a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (n
n, (a
x, Map n [Edge n b] -> n -> [Edge n b]
forall k a. Ord k => Map k [a] -> k -> [a]
fn Map n [Edge n b]
inc n
n, Map n [Edge n b] -> n -> [Edge n b]
forall k a. Ord k => Map k [a] -> k -> [a]
fn Map n [Edge n b]
out n
n)) | (n
n,a
x) <- Graph n a b -> [(n, a)]
forall n a b. Graph n a b -> [Node n a]
nodes Graph n a b
g ]
  where
  inc :: Map n [Edge n b]
inc = (Edge n b -> n) -> Graph n a b -> Map n [Edge n b]
forall n b a.
Ord n =>
(Edge n b -> n) -> Graph n a b -> Map n [Edge n b]
groupEdgesBy Edge n b -> n
forall n b. Edge n b -> n
edgeTo Graph n a b
g
  out :: Map n [Edge n b]
out = (Edge n b -> n) -> Graph n a b -> Map n [Edge n b]
forall n b a.
Ord n =>
(Edge n b -> n) -> Graph n a b -> Map n [Edge n b]
groupEdgesBy Edge n b -> n
forall n b. Edge n b -> n
edgeFrom Graph n a b
g
  fn :: Map k [a] -> k -> [a]
fn Map k [a]
m k
n = [a] -> Maybe [a] -> [a]
forall a. a -> Maybe a -> a
fromMaybe [] (k -> Map k [a] -> Maybe [a]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
n Map k [a]
m)

groupEdgesBy :: (Ord n) => (Edge n b -> n) -- ^ Gets the node to group by
             -> Graph n a b -> Map n [Edge n b]
groupEdgesBy :: (Edge n b -> n) -> Graph n a b -> Map n [Edge n b]
groupEdgesBy Edge n b -> n
f Graph n a b
g = ([Edge n b] -> [Edge n b] -> [Edge n b])
-> [(n, [Edge n b])] -> Map n [Edge n b]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [Edge n b] -> [Edge n b] -> [Edge n b]
forall a. [a] -> [a] -> [a]
(++) [(Edge n b -> n
f Edge n b
e, [Edge n b
e]) | Edge n b
e <- Graph n a b -> [Edge n b]
forall n a b. Graph n a b -> [Edge n b]
edges Graph n a b
g]

lookupNode :: Ord n => NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
lookupNode :: NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
lookupNode NodeInfo n a b
i n
n = Maybe (a, [Edge n b], [Edge n b]) -> (a, [Edge n b], [Edge n b])
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (a, [Edge n b], [Edge n b]) -> (a, [Edge n b], [Edge n b]))
-> Maybe (a, [Edge n b], [Edge n b]) -> (a, [Edge n b], [Edge n b])
forall a b. (a -> b) -> a -> b
$ n -> NodeInfo n a b -> Maybe (a, [Edge n b], [Edge n b])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup n
n NodeInfo n a b
i

getIncoming :: Ord n => NodeInfo n a b -> n -> [Edge n b]
getIncoming :: NodeInfo n a b -> n -> [Edge n b]
getIncoming NodeInfo n a b
i n
n = let (a
_,[Edge n b]
inc,[Edge n b]
_) = NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
forall n a b.
Ord n =>
NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
lookupNode NodeInfo n a b
i n
n in [Edge n b]
inc

getOutgoing :: Ord n => NodeInfo n a b -> n -> [Edge n b]
getOutgoing :: NodeInfo n a b -> n -> [Edge n b]
getOutgoing NodeInfo n a b
i n
n = let (a
_,[Edge n b]
_,[Edge n b]
out) = NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
forall n a b.
Ord n =>
NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
lookupNode NodeInfo n a b
i n
n in [Edge n b]
out

inDegree :: Ord n => NodeInfo n a b -> n -> Int
inDegree :: NodeInfo n a b -> n -> Int
inDegree NodeInfo n a b
i n
n = [Edge n b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Edge n b] -> Int) -> [Edge n b] -> Int
forall a b. (a -> b) -> a -> b
$ NodeInfo n a b -> n -> [Edge n b]
forall n a b. Ord n => NodeInfo n a b -> n -> [Edge n b]
getIncoming NodeInfo n a b
i n
n

outDegree :: Ord n => NodeInfo n a b -> n -> Int
outDegree :: NodeInfo n a b -> n -> Int
outDegree NodeInfo n a b
i n
n = [Edge n b] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Edge n b] -> Int) -> [Edge n b] -> Int
forall a b. (a -> b) -> a -> b
$ NodeInfo n a b -> n -> [Edge n b]
forall n a b. Ord n => NodeInfo n a b -> n -> [Edge n b]
getOutgoing NodeInfo n a b
i n
n

getNodeLabel :: Ord n => NodeInfo n a b -> n -> a
getNodeLabel :: NodeInfo n a b -> n -> a
getNodeLabel NodeInfo n a b
i n
n = let (a
l,[Edge n b]
_,[Edge n b]
_) = NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
forall n a b.
Ord n =>
NodeInfo n a b -> n -> (a, [Edge n b], [Edge n b])
lookupNode NodeInfo n a b
i n
n in a
l

nodeLabel :: Node n a -> a
nodeLabel :: Node n a -> a
nodeLabel = Node n a -> a
forall a b. (a, b) -> b
snd

edgeFrom :: Edge n b -> n
edgeFrom :: Edge n b -> n
edgeFrom (n
f,n
_,b
_) = n
f

edgeTo :: Edge n b -> n
edgeTo :: Edge n b -> n
edgeTo (n
_,n
t,b
_) = n
t

edgeLabel :: Edge n b -> b
edgeLabel :: Edge n b -> b
edgeLabel (n
_,n
_,b
l) = b
l

reverseGraph :: Graph n a b -> Graph n a b
reverseGraph :: Graph n a b -> Graph n a b
reverseGraph (Graph [n]
c [Node n a]
ns [Edge n b]
es) = [n] -> [Node n a] -> [Edge n b] -> Graph n a b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
c [Node n a]
ns [ (n
t,n
f,b
l) | (n
f,n
t,b
l) <- [Edge n b]
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 n a b -> Graph m a b -> (Graph n a b, m -> n)
mergeGraphs (Graph [n]
c [Node n a]
ns1 [Edge n b]
es1) Graph m a b
g2 = ([n] -> [Node n a] -> [Edge n b] -> Graph n a b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [n]
c' ([Node n a]
ns2[Node n a] -> [Node n a] -> [Node n a]
forall a. [a] -> [a] -> [a]
++[Node n a]
ns1) ([Edge n b]
es2[Edge n b] -> [Edge n b] -> [Edge n b]
forall a. [a] -> [a] -> [a]
++[Edge n b]
es1), m -> n
newName)
  where
  ([n]
xs,[n]
c') = Int -> [n] -> ([n], [n])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Node m a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Graph m a b -> [Node m a]
forall n a b. Graph n a b -> [Node n a]
nodes Graph m a b
g2)) [n]
c
  newNames :: Map m n
newNames = [(m, n)] -> Map m n
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([m] -> [n] -> [(m, n)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Node m a -> m) -> [Node m a] -> [m]
forall a b. (a -> b) -> [a] -> [b]
map Node m a -> m
forall a b. (a, b) -> a
fst (Graph m a b -> [Node m a]
forall n a b. Graph n a b -> [Node n a]
nodes Graph m a b
g2)) [n]
xs)
  newName :: m -> n
newName m
n = Maybe n -> n
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe n -> n) -> Maybe n -> n
forall a b. (a -> b) -> a -> b
$ m -> Map m n -> Maybe n
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup m
n Map m n
newNames
  Graph [n]
_ [Node n a]
ns2 [Edge n b]
es2 = (m -> n) -> [n] -> Graph m a b -> Graph n a b
forall n m a b. (n -> m) -> [m] -> Graph n a b -> Graph m a b
renameNodes m -> n
newName [n]
forall a. HasCallStack => a
undefined Graph m a b
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 :: (n -> m) -> [m] -> Graph n a b -> Graph m a b
renameNodes n -> m
newName [m]
c (Graph [n]
_ [Node n a]
ns [Edge n b]
es) = [m] -> [Node m a] -> [Edge m b] -> Graph m a b
forall n a b. [n] -> [Node n a] -> [Edge n b] -> Graph n a b
Graph [m]
c [Node m a]
ns' [Edge m b]
es'
    where ns' :: [Node m a]
ns' = (Node n a -> Node m a) -> [Node n a] -> [Node m a]
forall a b. (a -> b) -> [a] -> [b]
map' (\ (n
n,a
x) -> (n -> m
newName n
n,a
x)) [Node n a]
ns
          es' :: [Edge m b]
es' = (Edge n b -> Edge m b) -> [Edge n b] -> [Edge m b]
forall a b. (a -> b) -> [a] -> [b]
map' (\ (n
f,n
t,b
l) -> (n -> m
newName n
f, n -> m
newName n
t, b
l)) [Edge n b]
es

-- | A strict 'map'
map' :: (a -> b) -> [a] -> [b]
map' :: (a -> b) -> [a] -> [b]
map' a -> b
_ [] = []
map' a -> b
f (a
x:[a]
xs) = ((:) (b -> [b] -> [b]) -> b -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$! a -> b
f a
x) ([b] -> [b]) -> [b] -> [b]
forall a b. (a -> b) -> a -> b
$! (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map' a -> b
f [a]
xs