{-# LANGUAGE 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 [] -> fail "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 fail "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 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 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' -}