{-# 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
#if MIN_VERSION_base(4,12,0)
import Control.Monad.Fail
import Prelude hiding (fail)
#endif

{-# 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
#if MIN_VERSION_base(4,12,0)
 (MonadFail m)
#else
 (Monad m)
#endif
  => 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 m (gr a b)
g = do [LNode a]
vs <- m (gr a b) -> m [LNode a]
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m [LNode a]
labNodesM m (gr a b)
g
                   case [LNode a]
vs of
                     []      -> String -> m (GDecomp gr a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Match Exception, Empty Graph"
                     (Node
v,a
_):[LNode a]
_ -> do (Just Context a b
c,gr a b
g') <- Node -> m (gr a b) -> m (MContext a b, gr a b)
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
Node -> m (gr a b) -> m (Decomp gr a b)
matchM Node
v m (gr a b)
g
                                   GDecomp gr a b -> m (GDecomp gr a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context a b
c,gr a b
g')

  noNodesM   :: m (gr a b) -> m Int
  noNodesM = m (gr a b) -> m [LNode a]
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m [LNode a]
labNodesM (m (gr a b) -> m [LNode a])
-> ([LNode a] -> Node) -> m (gr a b) -> m Node
forall (m :: * -> *) a b c.
Monad m =>
(m a -> m b) -> (b -> c) -> m a -> m c
>>. [LNode a] -> Node
forall (t :: * -> *) a. Foldable t => t a -> Node
length

  nodeRangeM :: m (gr a b) -> m (Node,Node)
  nodeRangeM m (gr a b)
g = do Bool
isE <- m (gr a b) -> m Bool
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m Bool
isEmptyM m (gr a b)
g
                    if Bool
isE
                       then String -> m (Node, Node)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"nodeRangeM of empty graph"
                       else do [Node]
vs <- m (gr a b) -> m [Node]
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m [Node]
nodesM m (gr a b)
g
                               (Node, Node) -> m (Node, Node)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Node] -> Node
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Node]
vs,[Node] -> Node
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Node]
vs)

  labEdgesM  :: m (gr a b) -> m [LEdge b]
  labEdgesM = (Context a b -> [LEdge b] -> [LEdge b])
-> [LEdge b] -> m (gr a b) -> m [LEdge b]
forall (m :: * -> *) (gr :: * -> * -> *) a b c.
GraphM m gr =>
(Context a b -> c -> c) -> c -> m (gr a b) -> m c
ufoldM (\(Adj b
p,Node
v,a
_,Adj b
s)->((((b, Node) -> LEdge b) -> Adj b -> [LEdge b]
forall a b. (a -> b) -> [a] -> [b]
map (Node -> (b, Node) -> LEdge b
forall b c a. b -> (c, a) -> (a, b, c)
i Node
v) Adj b
p [LEdge b] -> [LEdge b] -> [LEdge b]
forall a. [a] -> [a] -> [a]
++ ((b, Node) -> LEdge b) -> Adj b -> [LEdge b]
forall a b. (a -> b) -> [a] -> [b]
map (Node -> (b, Node) -> LEdge b
forall a c b. a -> (c, b) -> (a, b, c)
o Node
v) Adj b
s)[LEdge b] -> [LEdge b] -> [LEdge b]
forall a. [a] -> [a] -> [a]
++)) []
    where
      o :: a -> (c, b) -> (a, b, c)
o a
v = \(c
l,b
w)->(a
v,b
w,c
l)
      i :: b -> (c, a) -> (a, b, c)
i b
v = \(c
l,a
w)->(a
w,b
v,c
l)


-- composing a monadic function with a non-monadic one
--
(>>.) :: (Monad m) => (m a -> m b) -> (b -> c) -> m a -> m c
m a -> m b
f >>. :: (m a -> m b) -> (b -> c) -> m a -> m c
>>. b -> c
g = (m b -> (b -> m c) -> m c
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> m c) -> (b -> c) -> b -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> c
g) (m b -> m c) -> (m a -> m b) -> m a -> m c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m b
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 :: (Context a b -> c -> c) -> c -> m (gr a b) -> m c
ufoldM Context a b -> c -> c
f c
u m (gr a b)
g = do Bool
b <- m (gr a b) -> m Bool
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m Bool
isEmptyM m (gr a b)
g
                  if Bool
b then c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return c
u
                       else do (Context a b
c,gr a b
g') <- m (gr a b) -> m (Context a b, gr a b)
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m (GDecomp gr a b)
matchAnyM m (gr a b)
g
                               c
x <- (Context a b -> c -> c) -> c -> m (gr a b) -> m c
forall (m :: * -> *) (gr :: * -> * -> *) a b c.
GraphM m gr =>
(Context a b -> c -> c) -> c -> m (gr a b) -> m c
ufoldM Context a b -> c -> c
f c
u (gr a b -> m (gr a b)
forall (m :: * -> *) a. Monad m => a -> m a
return gr a b
g')
                               c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return (Context a b -> c -> c
f Context a b
c 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 :: m (gr a b) -> m [Node]
nodesM = m (gr a b) -> m [LNode a]
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m [LNode a]
labNodesM (m (gr a b) -> m [LNode a])
-> ([LNode a] -> [Node]) -> m (gr a b) -> m [Node]
forall (m :: * -> *) a b c.
Monad m =>
(m a -> m b) -> (b -> c) -> m a -> m c
>>. (LNode a -> Node) -> [LNode a] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map LNode a -> Node
forall a b. (a, b) -> a
fst

edgesM :: (GraphM m gr) => m (gr a b) -> m [Edge]
edgesM :: m (gr a b) -> m [(Node, Node)]
edgesM =  m (gr a b) -> m [LEdge b]
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m [LEdge b]
labEdgesM (m (gr a b) -> m [LEdge b])
-> ([LEdge b] -> [(Node, Node)]) -> m (gr a b) -> m [(Node, Node)]
forall (m :: * -> *) a b c.
Monad m =>
(m a -> m b) -> (b -> c) -> m a -> m c
>>. (LEdge b -> (Node, Node)) -> [LEdge b] -> [(Node, Node)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Node
v,Node
w,b
_)->(Node
v,Node
w))

newNodesM :: (GraphM m gr) => Int -> m (gr a b) -> m [Node]
newNodesM :: Node -> m (gr a b) -> m [Node]
newNodesM Node
i m (gr a b)
g = do Bool
isE <- m (gr a b) -> m Bool
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m Bool
isEmptyM m (gr a b)
g
                   if Bool
isE
                      then [Node] -> m [Node]
forall (m :: * -> *) a. Monad m => a -> m a
return [Node
0..Node
iNode -> Node -> Node
forall a. Num a => a -> a -> a
-Node
1]
                      else do (Node
_,Node
n) <- m (gr a b) -> m (Node, Node)
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
m (gr a b) -> m (Node, Node)
nodeRangeM m (gr a b)
g
                              [Node] -> m [Node]
forall (m :: * -> *) a. Monad m => a -> m a
return [Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
1..Node
nNode -> Node -> Node
forall a. Num a => a -> a -> a
+Node
i]


-- graph construction & destruction
--
delNodeM :: (GraphM m gr) => Node -> m (gr a b) -> m (gr a b)
delNodeM :: Node -> m (gr a b) -> m (gr a b)
delNodeM Node
v = [Node] -> m (gr a b) -> m (gr a b)
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
[Node] -> m (gr a b) -> m (gr a b)
delNodesM [Node
v]

delNodesM :: (GraphM m gr) => [Node] -> m (gr a b) -> m (gr a b)
delNodesM :: [Node] -> m (gr a b) -> m (gr a b)
delNodesM []     m (gr a b)
g = m (gr a b)
g
delNodesM (Node
v:[Node]
vs) m (gr a b)
g = do (MContext a b
_,gr a b
g') <- Node -> m (gr a b) -> m (MContext a b, gr a b)
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
Node -> m (gr a b) -> m (Decomp gr a b)
matchM Node
v m (gr a b)
g
                        [Node] -> m (gr a b) -> m (gr a b)
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
[Node] -> m (gr a b) -> m (gr a b)
delNodesM [Node]
vs (gr a b -> m (gr a b)
forall (m :: * -> *) a. Monad m => a -> m a
return gr a b
g')

mkUGraphM :: (GraphM m gr) => [Node] -> [Edge] -> m (gr () ())
mkUGraphM :: [Node] -> [(Node, Node)] -> m (gr () ())
mkUGraphM [Node]
vs [(Node, Node)]
es = [LNode ()] -> [LEdge ()] -> m (gr () ())
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
[LNode a] -> [LEdge b] -> m (gr a b)
mkGraphM ([Node] -> [LNode ()]
labUNodes [Node]
vs) ([(Node, Node)] -> [LEdge ()]
labUEdges [(Node, Node)]
es)

labUEdges :: [Edge] -> [LEdge ()]
labUEdges :: [(Node, Node)] -> [LEdge ()]
labUEdges = ((Node, Node) -> LEdge ()) -> [(Node, Node)] -> [LEdge ()]
forall a b. (a -> b) -> [a] -> [b]
map ((Node, Node) -> () -> LEdge ()
forall b. (Node, Node) -> b -> LEdge b
`toLEdge` ())

labUNodes :: [Node] -> [LNode ()]
labUNodes :: [Node] -> [LNode ()]
labUNodes = (Node -> LNode ()) -> [Node] -> [LNode ()]
forall a b. (a -> b) -> [a] -> [b]
map (\Node
v->(Node
v,()))


-- graph inspection (for a particular node)
--
onMatch :: (GraphM m gr) => (Context a b -> c) -> c -> m (gr a b) -> Node -> m c
onMatch :: (Context a b -> c) -> c -> m (gr a b) -> Node -> m c
onMatch Context a b -> c
f c
u m (gr a b)
g Node
v = do (MContext a b
x,gr a b
_) <- Node -> m (gr a b) -> m (MContext a b, gr a b)
forall (m :: * -> *) (gr :: * -> * -> *) a b.
GraphM m gr =>
Node -> m (gr a b) -> m (Decomp gr a b)
matchM Node
v m (gr a b)
g
                     c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return (case MContext a b
x of {MContext a b
Nothing -> c
u; Just Context a b
c -> Context a b -> c
f Context a b
c})

contextM :: (GraphM m gr) => m (gr a b) -> Node -> m (Context a b)
contextM :: m (gr a b) -> Node -> m (Context a b)
contextM m (gr a b)
g Node
v = (Context a b -> Context a b)
-> Context a b -> m (gr a b) -> Node -> m (Context a b)
forall (m :: * -> *) (gr :: * -> * -> *) a b c.
GraphM m gr =>
(Context a b -> c) -> c -> m (gr a b) -> Node -> m c
onMatch Context a b -> Context a b
forall a. a -> a
id (String -> Context a b
forall a. HasCallStack => String -> a
error (String
"Match Exception, Node: "String -> String -> String
forall a. [a] -> [a] -> [a]
++Node -> String
forall a. Show a => a -> String
show Node
v)) m (gr a b)
g Node
v

labM :: (GraphM m gr) => m (gr a b) -> Node -> m (Maybe a)
labM :: m (gr a b) -> Node -> m (Maybe a)
labM = (Context a b -> Maybe a)
-> Maybe a -> m (gr a b) -> Node -> m (Maybe a)
forall (m :: * -> *) (gr :: * -> * -> *) a b c.
GraphM m gr =>
(Context a b -> c) -> c -> m (gr a b) -> Node -> m c
onMatch (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> (Context a b -> a) -> Context a b -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context a b -> a
forall a b. Context a b -> a
lab') Maybe a
forall a. Maybe a
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'


-}