fgl-5.8.0.0: Data/Graph/Inductive/Monad.hs
{-# LANGUAGE CPP, MultiParamTypeClasses #-}
-- (c) 2002 by Martin Erwig [see file COPYRIGHT]
-- | Monadic Graphs
module Data.Graph.Inductive.Monad(
-- * Classes
GraphM(..),
-- * Operations
-- ** Graph Folds and Maps
ufoldM,
-- ** Graph Projection
nodesM,edgesM,newNodesM,
-- ** Graph Construction and Destruction
delNodeM,delNodesM,
mkUGraphM,
-- ** Graph Inspection
contextM,labM
) where
import Data.Graph.Inductive.Graph
{-# ANN module "HLint: ignore Redundant lambda" #-}
----------------------------------------------------------------------
-- MONADIC GRAPH CLASS
----------------------------------------------------------------------
--
-- Currently, we define just one monadic graph class:
--
-- GraphM: static, decomposable graphs
-- static means that a graph itself cannot be changed
--
-- Later we might also define DynGraphM for dynamic, extensible graphs
--
-- Monadic Graph
--
class (Monad m) => GraphM m gr where
{-# MINIMAL emptyM, isEmptyM, matchM, mkGraphM, labNodesM #-}
emptyM :: m (gr a b)
isEmptyM :: m (gr a b) -> m Bool
matchM :: Node -> m (gr a b) -> m (Decomp gr a b)
mkGraphM :: [LNode a] -> [LEdge b] -> m (gr a b)
labNodesM :: m (gr a b) -> m [LNode a]
matchAnyM :: m (gr a b) -> m (GDecomp gr a b)
matchAnyM g = do vs <- labNodesM g
case vs of
[] -> error "Match Exception, Empty Graph"
(v,_):_ -> do ~(Just c,g') <- matchM v g
return (c,g')
noNodesM :: m (gr a b) -> m Int
noNodesM = labNodesM >>. length
nodeRangeM :: m (gr a b) -> m (Node,Node)
nodeRangeM g = do isE <- isEmptyM g
if isE
then error "nodeRangeM of empty graph"
else do vs <- nodesM g
return (minimum vs,maximum vs)
labEdgesM :: m (gr a b) -> m [LEdge b]
labEdgesM = ufoldM (\(p,v,_,s)->((map (i v) p ++ map (o v) s)++)) []
where
o v = \(l,w)->(v,w,l)
i v = \(l,w)->(w,v,l)
-- composing a monadic function with a non-monadic one
--
(>>.) :: (Monad m) => (m a -> m b) -> (b -> c) -> m a -> m c
f >>. g = (>>= return . g) . f
----------------------------------------------------------------------
-- DERIVED GRAPH OPERATIONS
----------------------------------------------------------------------
-- graph folds and maps
--
-- | graph fold
ufoldM :: (GraphM m gr) => (Context a b -> c -> c) -> c -> m (gr a b) -> m c
ufoldM f u g = do b <- isEmptyM g
if b then return u
else do (c,g') <- matchAnyM g
x <- ufoldM f u (return g')
return (f c x)
-- (additional) graph projection
-- [noNodes, nodeRange, labNodes, labEdges are defined in class Graph]
--
nodesM :: (GraphM m gr) => m (gr a b) -> m [Node]
nodesM = labNodesM >>. map fst
edgesM :: (GraphM m gr) => m (gr a b) -> m [Edge]
edgesM = labEdgesM >>. map (\(v,w,_)->(v,w))
newNodesM :: (GraphM m gr) => Int -> m (gr a b) -> m [Node]
newNodesM i g = do isE <- isEmptyM g
if isE
then return [0..i-1]
else do (_,n) <- nodeRangeM g
return [n+1..n+i]
-- graph construction & destruction
--
delNodeM :: (GraphM m gr) => Node -> m (gr a b) -> m (gr a b)
delNodeM v = delNodesM [v]
delNodesM :: (GraphM m gr) => [Node] -> m (gr a b) -> m (gr a b)
delNodesM [] g = g
delNodesM (v:vs) g = do (_,g') <- matchM v g
delNodesM vs (return g')
mkUGraphM :: (GraphM m gr) => [Node] -> [Edge] -> m (gr () ())
mkUGraphM vs es = mkGraphM (labUNodes vs) (labUEdges es)
labUEdges :: [Edge] -> [LEdge ()]
labUEdges = map (`toLEdge` ())
labUNodes :: [Node] -> [LNode ()]
labUNodes = map (\v->(v,()))
-- graph inspection (for a particular node)
--
onMatch :: (GraphM m gr) => (Context a b -> c) -> c -> m (gr a b) -> Node -> m c
onMatch f u g v = do (x,_) <- matchM v g
return (case x of {Nothing -> u; Just c -> f c})
contextM :: (GraphM m gr) => m (gr a b) -> Node -> m (Context a b)
contextM g v = onMatch id (error ("Match Exception, Node: "++show v)) g v
labM :: (GraphM m gr) => m (gr a b) -> Node -> m (Maybe a)
labM = onMatch (Just . lab') Nothing
{-
neighbors :: (GraphM m gr) => m (gr a b) -> Node -> [Node]
neighbors = (\(p,_,_,s) -> map snd (p++s)) .: context
suc :: (GraphM m gr) => m (gr a b) -> Node -> [Node]
suc = map snd .: context4
pre :: (GraphM m gr) => m (gr a b) -> Node -> [Node]
pre = map snd .: context1
lsuc :: (GraphM m gr) => m (gr a b) -> Node -> [(Node,b)]
lsuc = map flip2 .: context4
lpre :: (GraphM m gr) => m (gr a b) -> Node -> [(Node,b)]
lpre = map flip2 .: context1
out :: (GraphM m gr) => m (gr a b) -> Node -> [LEdge b]
out g v = map (\(l,w)->(v,w,l)) (context4 g v)
inn :: (GraphM m gr) => m (gr a b) -> Node -> [LEdge b]
inn g v = map (\(l,w)->(w,v,l)) (context1 g v)
outdeg :: (GraphM m gr) => m (gr a b) -> Node -> Int
outdeg = length .: context4
indeg :: (GraphM m gr) => m (gr a b) -> Node -> Int
indeg = length .: context1
deg :: (GraphM m gr) => m (gr a b) -> Node -> Int
deg = (\(p,_,_,s) -> length p+length s) .: context
--
-- -- context inspection
-- --
-- node' :: Context a b -> Node
-- node' (_,v,_,_) = v
--
-- lab' :: Context a b -> a
-- lab' (_,_,l,_) = l
--
-- labNode' :: Context a b -> LNode a
-- labNode' (_,v,l,_) = (v,l)
--
-- neighbors' :: Context a b -> [Node]
-- neighbors' (p,_,_,s) = map snd p++map snd s
--
-- suc' :: Context a b -> [Node]
-- suc' (_,_,_,s) = map snd s
--
-- pre' :: Context a b -> [Node]
-- pre' (p,_,_,_) = map snd p
--
-- lpre' :: Context a b -> [(Node,b)]
-- lpre' (p,_,_,_) = map flip2 p
--
-- lsuc' :: Context a b -> [(Node,b)]
-- lsuc' (_,_,_,s) = map flip2 s
--
-- out' :: Context a b -> [LEdge b]
-- out' (_,v,_,s) = map (\(l,w)->(v,w,l)) s
--
-- inn' :: Context a b -> [LEdge b]
-- inn' (p,v,_,_) = map (\(l,w)->(w,v,l)) p
--
-- outdeg' :: Context a b -> Int
-- outdeg' (_,_,_,s) = length s
--
-- indeg' :: Context a b -> Int
-- indeg' (p,_,_,_) = length p
--
-- deg' :: Context a b -> Int
-- deg' (p,_,_,s) = length p+length s
-- graph equality
--
nodeComp :: (Eq b) => LNode b -> LNode b -> Ordering
nodeComp n@(v,a) n'@(w,b) | n == n' = EQ
| v<w = LT
| otherwise = GT
slabNodes :: (Eq a,Graph gr) => m (gr a b) -> [LNode a]
slabNodes = sortBy nodeComp . labNodes
edgeComp :: (Eq b) => LEdge b -> LEdge b -> Ordering
edgeComp e@(v,w,a) e'@(x,y,b) | e == e' = EQ
| v<x || (v==x && w<y) = LT
| otherwise = GT
slabEdges :: (Eq b,Graph gr) => m (gr a b) -> [LEdge b]
slabEdges = sortBy edgeComp . labEdges
instance (Eq a,Eq b,Graph gr) => Eq (m (gr a b)) where
g == g' = slabNodes g == slabNodes g' && slabEdges g == slabEdges g'
-}