    {-# 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  = return
        (<*>) = ap

    instance (Monad m) => Monad (GT m g) where
      return x = MGT (\mg->do {g<-mg; return (x,g)})
      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
                 if b||null vs then return ([],g) else
                    let (v:vs') = vs in
                    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)
              )

    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}