Monad.hs

{-# LANGUAGE CPP, MultiParamTypeClasses #-}

-- (c) 2002 by Martin Erwig [see file COPYRIGHT]
-- | Monadic Graph Algorithms

module Data.Graph.Inductive.Query.Monad(
    -- * Additional Graph Utilities
    mapFst, mapSnd, (><), orP,
    -- * Graph Transformer Monad
    GT(..), apply, apply', applyWith, applyWith', runGT, condMGT', recMGT',
    condMGT, recMGT,
    -- * Graph Computations Based on Graph Monads
    -- ** Monadic Graph Accessing Functions
    getNode, getContext, getNodes', getNodes, sucGT, sucM,
    -- ** Derived Graph Recursion Operators
    graphRec, graphRec', graphUFold,
    -- * Examples: Graph Algorithms as Instances of Recursion Operators
    -- ** Instances of graphRec
    graphNodesM0, graphNodesM, graphNodes, graphFilterM, graphFilter,
    -- * Example: Monadic DFS Algorithm(s)
    dfsGT, dfsM, dfsM', dffM, graphDff, graphDff',
) where


-- Why all this?
--
-- graph monad ensures single-threaded access
--  ==> we can safely use imperative updates in the graph implementation
--

import Control.Monad (ap, liftM, liftM2)
import Data.Tree

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative (..))
#endif

import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Monad

-- some additional (graph) utilities
--
mapFst :: (a -> b) -> (a, c) -> (b, c)
mapFst f (x,y) = (f x,y)
mapSnd :: (a -> b) -> (c, a) -> (c, b)
mapSnd f (x,y) = (x,f y)

infixr 8 ><
(><) :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
(f >< g) (x,y) = (f x,g y)

orP :: (a -> Bool) -> (b -> Bool) -> (a,b) -> Bool
orP p q (x,y) = p x || q y

----------------------------------------------------------------------
-- "wrapped" state transformer monad   ==
-- monadic graph transformer monad
----------------------------------------------------------------------

newtype GT m g a = MGT (m g -> m (a,g))

apply :: GT m g a -> m g -> m (a,g)
apply (MGT f) = f

apply' :: (Monad m) => GT m g a -> g -> m (a,g)
apply' gt = apply gt . return

applyWith :: (Monad m) => (a -> b) -> GT m g a -> m g -> m (b,g)
applyWith h (MGT f) gm = do {(x,g) <- f gm; return (h x,g)}

applyWith' :: (Monad m) => (a -> b) -> GT m g a -> g -> m (b,g)
applyWith' h gt = applyWith h gt . return

runGT :: (Monad m) => GT m g a -> m g -> m a
runGT gt mg = do {(x,_) <- apply gt mg; return x}

instance (Monad m) => Functor (GT m g) where
    fmap  = liftM

instance (Monad m) => Applicative (GT m g) where
    pure x  = MGT (\mg->do {g<-mg; return (x,g)})
    (<*>) = ap

instance (Monad m) => Monad (GT m g) where
  return = pure
  f >>= h  = MGT (\mg->do {(x,g)<-apply f mg; apply' (h x) g})

condMGT' :: (Monad m) => (s -> Bool) -> GT m s a -> GT m s a -> GT m s a
condMGT' p f g = MGT (\mg->do {h<-mg; if p h then apply f mg else apply g mg})

recMGT' :: (Monad m) => (s -> Bool) -> GT m s a -> (a -> b -> b) -> b -> GT m s b
recMGT' p mg f u = condMGT' p (return u)
                            (do {x<-mg;y<-recMGT' p mg f u;return (f x y)})

condMGT :: (Monad m) => (m s -> m Bool) -> GT m s a -> GT m s a -> GT m s a
condMGT p f g = MGT (\mg->do {b<-p mg; if b then apply f mg else apply g mg})

recMGT :: (Monad m) => (m s -> m Bool) -> GT m s a -> (a -> b -> b) -> b -> GT m s b
recMGT p mg f u = condMGT p (return u)
                          (do {x<-mg;y<-recMGT p mg f u;return (f x y)})


----------------------------------------------------------------------
-- graph computations based on state monads/graph monads
----------------------------------------------------------------------


-- some monadic graph accessing functions
--
getNode :: (GraphM m gr) => GT m (gr a b) Node
getNode = MGT (\mg->do {((_,v,_,_),g) <- matchAnyM mg; return (v,g)})

getContext :: (GraphM m gr) => GT m (gr a b) (Context a b)
getContext = MGT matchAnyM

-- some functions defined by using the do-notation explicitly
-- Note: most of these can be expressed as an instance of graphRec
--
getNodes' :: (Graph gr,GraphM m gr) => GT m (gr a b) [Node]
getNodes' = condMGT' isEmpty (return []) nodeGetter

getNodes :: (GraphM m gr) => GT m (gr a b) [Node]
getNodes = condMGT isEmptyM (return []) nodeGetter

nodeGetter :: (GraphM m gr) => GT m (gr a b) [Node]
nodeGetter = liftM2 (:) getNode getNodes

sucGT :: (GraphM m gr) => Node -> GT m (gr a b) (Maybe [Node])
sucGT v = MGT (\mg->do (c,g) <- matchM v mg
                       case c of
                         Just (_,_,_,s) -> return (Just (map snd s),g)
                         Nothing        -> return (Nothing,g)
              )

sucM :: (GraphM m gr) => Node -> m (gr a b) -> m (Maybe [Node])
sucM v = runGT (sucGT v)



----------------------------------------------------------------------
-- some derived graph recursion operators
----------------------------------------------------------------------

--
-- graphRec :: GraphMonad a b c -> (c -> d -> d) -> d -> GraphMonad a b d
-- graphRec f g u = cond isEmpty (return u)
--                               (do x <- f
--                                   y <- graphRec f g u
--                                   return (g x y))

-- | encapsulates a simple recursion schema on graphs
graphRec :: (GraphM m gr) => GT m (gr a b) c ->
                           (c -> d -> d) -> d -> GT m (gr a b) d
graphRec = recMGT isEmptyM

graphRec' :: (Graph gr,GraphM m gr) => GT m (gr a b) c ->
                           (c -> d -> d) -> d -> GT m (gr a b) d
graphRec' = recMGT' isEmpty

graphUFold :: (GraphM m gr) => (Context a b -> c -> c) -> c -> GT m (gr a b) c
graphUFold = graphRec getContext



----------------------------------------------------------------------
-- Examples: graph algorithms as instances of recursion operators
----------------------------------------------------------------------

-- instances of graphRec
--
graphNodesM0 :: (GraphM m gr) => GT m (gr a b) [Node]
graphNodesM0 = graphRec getNode (:) []

graphNodesM :: (GraphM m gr) => GT m (gr a b) [Node]
graphNodesM = graphUFold (\(_,v,_,_)->(v:)) []

graphNodes :: (GraphM m gr) => m (gr a b) -> m [Node]
graphNodes = runGT graphNodesM

graphFilterM :: (GraphM m gr) => (Context a b -> Bool) ->
                              GT m (gr a b) [Context a b]
graphFilterM p = graphUFold (\c cs->if p c then c:cs else cs) []

graphFilter :: (GraphM m gr) => (Context a b -> Bool) -> m (gr a b) -> m [Context a b]
graphFilter p = runGT (graphFilterM p)




----------------------------------------------------------------------
-- Example: monadic dfs algorithm(s)
----------------------------------------------------------------------

-- | Monadic graph algorithms are defined in two steps:
--
--  (1) define the (possibly parameterized) graph transformer (e.g., dfsGT)
--  (2) run the graph transformer (applied to arguments) (e.g., dfsM)
--

dfsGT :: (GraphM m gr) => [Node] -> GT m (gr a b) [Node]
dfsGT []     = return []
dfsGT (v:vs) = MGT (\mg->
               do (mc,g') <- matchM v mg
                  case mc of
                    Just (_,_,_,s) -> applyWith' (v:) (dfsGT (map snd s++vs)) g'
                    Nothing        -> apply' (dfsGT vs) g'  )

-- | depth-first search yielding number of nodes
dfsM :: (GraphM m gr) => [Node] -> m (gr a b) -> m [Node]
dfsM vs = runGT (dfsGT vs)

dfsM' :: (GraphM m gr) => m (gr a b) -> m [Node]
dfsM' mg = do {vs <- nodesM mg; runGT (dfsGT vs) mg}


-- | depth-first search yielding dfs forest
dffM :: (GraphM m gr) => [Node] -> GT m (gr a b) [Tree Node]
dffM vs = MGT (\mg->
          do g<-mg
             b<-isEmptyM mg
             case (b, vs) of
               (False, v:vs') -> do
                   (mc,g1) <- matchM v mg
                   case mc of
                     Nothing -> apply (dffM vs') (return g1)
                     Just c  -> do (ts, g2) <- apply (dffM (suc' c)) (return g1)
                                   (ts',g3) <- apply (dffM vs') (return g2)
                                   return (Node (node' c) ts:ts',g3)
               _ -> return ([],g)
          )

graphDff :: (GraphM m gr) => [Node] -> m (gr a b) -> m [Tree Node]
graphDff vs = runGT (dffM vs)

graphDff' :: (GraphM m gr) => m (gr a b) -> m [Tree Node]
graphDff' mg = do {vs <- nodesM mg; runGT (dffM vs) mg}