{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DeriveGeneric #-}
#endif

-- (c) 1999 - 2002 by Martin Erwig [see file COPYRIGHT]
-- | Tree-based implementation of 'Graph' and 'DynGraph'
--
--   You will probably have better performance using the
--   "Data.Graph.Inductive.PatriciaTree" implementation instead.

module Data.Graph.Inductive.Tree (Gr,UGr) where

import Data.Graph.Inductive.Graph

import           Control.Applicative (liftA2)
import           Data.List           (foldl', sort)
import           Data.Map            (Map)
import qualified Data.Map            as M
import           Data.Maybe          (fromMaybe)

#if MIN_VERSION_containers (0,4,2)
import Control.DeepSeq (NFData (..))
#endif

#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics (Generic)
#endif

#if MIN_VERSION_base (4,8,0)
import Data.Bifunctor
#else
import Control.Arrow (first, second)
#endif

----------------------------------------------------------------------
-- GRAPH REPRESENTATION
----------------------------------------------------------------------

newtype Gr a b = Gr (GraphRep a b)
#if __GLASGOW_HASKELL__ >= 702
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (Gr a b) x -> Gr a b
forall a b x. Gr a b -> Rep (Gr a b) x
$cto :: forall a b x. Rep (Gr a b) x -> Gr a b
$cfrom :: forall a b x. Gr a b -> Rep (Gr a b) x
Generic)
#endif

type GraphRep a b = Map Node (Context' a b)
type Context' a b = (Adj b,a,Adj b)

type UGr = Gr () ()

----------------------------------------------------------------------
-- CLASS INSTANCES
----------------------------------------------------------------------

instance (Eq a, Ord b) => Eq (Gr a b) where
  (Gr Map Node ([(b, Node)], a, [(b, Node)])
g1) == :: Gr a b -> Gr a b -> Bool
== (Gr Map Node ([(b, Node)], a, [(b, Node)])
g2) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a} {b}.
(Ord a, Ord a) =>
([a], b, [a]) -> ([a], b, [a])
sortAdj Map Node ([(b, Node)], a, [(b, Node)])
g1 forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {a} {b}.
(Ord a, Ord a) =>
([a], b, [a]) -> ([a], b, [a])
sortAdj Map Node ([(b, Node)], a, [(b, Node)])
g2
    where
      sortAdj :: ([a], b, [a]) -> ([a], b, [a])
sortAdj ([a]
p,b
n,[a]
s) = (forall a. Ord a => [a] -> [a]
sort [a]
p,b
n,forall a. Ord a => [a] -> [a]
sort [a]
s)

instance (Show a, Show b) => Show (Gr a b) where
  showsPrec :: Node -> Gr a b -> ShowS
showsPrec Node
d Gr a b
g = Bool -> ShowS -> ShowS
showParen (Node
d forall a. Ord a => a -> a -> Bool
> Node
10) forall a b. (a -> b) -> a -> b
$
                    String -> ShowS
showString String
"mkGraph "
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes Gr a b
g)
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges Gr a b
g)

instance (Read a, Read b) => Read (Gr a b) where
  readsPrec :: Node -> ReadS (Gr a b)
readsPrec Node
p = forall a. Bool -> ReadS a -> ReadS a
readParen (Node
p forall a. Ord a => a -> a -> Bool
> Node
10) forall a b. (a -> b) -> a -> b
$ \ String
r -> do
    (String
"mkGraph", String
s) <- ReadS String
lex String
r
    ([LNode a]
ns,String
t) <- forall a. Read a => ReadS a
reads String
s
    ([LEdge b]
es,String
u) <- forall a. Read a => ReadS a
reads String
t
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode a]
ns [LEdge b]
es, String
u)

-- Graph
--
instance Graph Gr where
  empty :: forall a b. Gr a b
empty             = forall a b. GraphRep a b -> Gr a b
Gr forall k a. Map k a
M.empty

  isEmpty :: forall a b. Gr a b -> Bool
isEmpty (Gr GraphRep a b
g)    = forall k a. Map k a -> Bool
M.null GraphRep a b
g

  match :: forall a b. Node -> Gr a b -> Decomp Gr a b
match Node
v gr :: Gr a b
gr@(Gr GraphRep a b
g) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. Maybe a
Nothing, Gr a b
gr)
                            (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a b.
Node -> Context' a b -> GraphRep a b -> (Context a b, Gr a b)
cleanSplit Node
v))
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Maybe (Context' a b)
m,GraphRep a b
g') -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) GraphRep a b
g') Maybe (Context' a b)
m)
                      forall a b. (a -> b) -> a -> b
$ forall k a.
Ord k =>
(k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)
M.updateLookupWithKey (forall a b. a -> b -> a
const (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)) Node
v GraphRep a b
g

  mkGraph :: forall a b. [LNode a] -> [LEdge b] -> Gr a b
mkGraph [LNode a]
vs [LEdge b]
es     = forall (gr :: * -> * -> *) b a.
DynGraph gr =>
[LEdge b] -> gr a b -> gr a b
insEdges [LEdge b]
es
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. GraphRep a b -> Gr a b
Gr
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (\a
l -> ([],a
l,[])))
                      forall a b. (a -> b) -> a -> b
$ [LNode a]
vs

  labNodes :: forall a b. Gr a b -> [LNode a]
labNodes (Gr GraphRep a b
g)   = forall a b. (a -> b) -> [a] -> [b]
map (\(Node
v,(Adj b
_,a
l,Adj b
_))->(Node
v,a
l)) (forall k a. Map k a -> [(k, a)]
M.toList GraphRep a b
g)

  matchAny :: forall a b. Gr a b -> GDecomp Gr a b
matchAny (Gr GraphRep a b
g)   = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"Match Exception, Empty Graph")
                            (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b.
Node -> Context' a b -> GraphRep a b -> (Context a b, Gr a b)
cleanSplit))
                            (forall k a. Map k a -> Maybe ((k, a), Map k a)
M.minViewWithKey GraphRep a b
g)

  noNodes :: forall a b. Gr a b -> Node
noNodes   (Gr GraphRep a b
g)  = forall k a. Map k a -> Node
M.size GraphRep a b
g

  nodeRange :: forall a b. Gr a b -> (Node, Node)
nodeRange (Gr GraphRep a b
g)  = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"nodeRange of empty graph")
                      forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (forall {b} {b} {b}. Maybe ((b, b), b) -> Maybe b
ix (forall k a. Map k a -> Maybe ((k, a), Map k a)
M.minViewWithKey GraphRep a b
g))
                                   (forall {b} {b} {b}. Maybe ((b, b), b) -> Maybe b
ix (forall k a. Map k a -> Maybe ((k, a), Map k a)
M.maxViewWithKey GraphRep a b
g))
    where
      ix :: Maybe ((b, b), b) -> Maybe b
ix            = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

  labEdges :: forall a b. Gr a b -> [LEdge b]
labEdges  (Gr GraphRep a b
g)  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Node
v,(Adj b
_,a
_,Adj b
s))->forall a b. (a -> b) -> [a] -> [b]
map (\(b
l,Node
w)->(Node
v,Node
w,b
l)) Adj b
s) (forall k a. Map k a -> [(k, a)]
M.toList GraphRep a b
g)

-- After a Node (with its corresponding Context') are split out of a
-- GraphRep, clean up the remainders.
cleanSplit :: Node -> Context' a b -> GraphRep a b
              -> (Context a b, Gr a b)
cleanSplit :: forall a b.
Node -> Context' a b -> GraphRep a b -> (Context a b, Gr a b)
cleanSplit Node
v (Adj b
p,a
l,Adj b
s) GraphRep a b
g = ((Adj b, Node, a, Adj b)
c, forall a b. GraphRep a b -> Gr a b
Gr GraphRep a b
g')
  where
    -- Note: loops are kept only in successor list
    c :: (Adj b, Node, a, Adj b)
c = (Adj b
p', Node
v, a
l, Adj b
s)
    p' :: Adj b
p' = forall {a}. [(a, Node)] -> [(a, Node)]
rmLoops Adj b
p
    s' :: Adj b
s' = forall {a}. [(a, Node)] -> [(a, Node)]
rmLoops Adj b
s
    rmLoops :: [(a, Node)] -> [(a, Node)]
rmLoops = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=Node
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)

    g' :: GraphRep a b
g' = forall b a.
Adj b
-> (b -> Context' a b -> Context' a b)
-> GraphRep a b
-> GraphRep a b
updAdj Adj b
s' (forall b a. Node -> b -> Context' a b -> Context' a b
clearPred Node
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a.
Adj b
-> (b -> Context' a b -> Context' a b)
-> GraphRep a b
-> GraphRep a b
updAdj Adj b
p' (forall b a. Node -> b -> Context' a b -> Context' a b
clearSucc Node
v) forall a b. (a -> b) -> a -> b
$ GraphRep a b
g

-- DynGraph
--
instance DynGraph Gr where
  (Adj b
p,Node
v,a
l,Adj b
s) & :: forall a b. Context a b -> Gr a b -> Gr a b
& (Gr GraphRep a b
g) = forall a b. GraphRep a b -> Gr a b
Gr
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a.
Adj b
-> (b -> Context' a b -> Context' a b)
-> GraphRep a b
-> GraphRep a b
updAdj Adj b
p (forall b a. Node -> b -> Context' a b -> Context' a b
addSucc Node
v)
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a.
Adj b
-> (b -> Context' a b -> Context' a b)
-> GraphRep a b
-> GraphRep a b
updAdj Adj b
s (forall b a. Node -> b -> Context' a b -> Context' a b
addPred Node
v)
                       forall a b. (a -> b) -> a -> b
$ forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter forall {a}. Maybe a -> Maybe (Adj b, a, Adj b)
addCntxt Node
v GraphRep a b
g
    where
      addCntxt :: Maybe a -> Maybe (Adj b, a, Adj b)
addCntxt = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just (Adj b, a, Adj b)
cntxt')
                       (forall a b. a -> b -> a
const (forall a. HasCallStack => String -> a
error (String
"Node Exception, Node: "forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Node
v)))
      cntxt' :: (Adj b, a, Adj b)
cntxt' = (Adj b
p,a
l,Adj b
s)

#if MIN_VERSION_containers (0,4,2)
instance (NFData a, NFData b) => NFData (Gr a b) where
  rnf :: Gr a b -> ()
rnf (Gr GraphRep a b
g) = forall a. NFData a => a -> ()
rnf GraphRep a b
g
#endif

instance Functor (Gr a) where
  fmap :: forall a b. (a -> b) -> Gr a a -> Gr a b
fmap = forall (gr :: * -> * -> *) b c a.
DynGraph gr =>
(b -> c) -> gr a b -> gr a c
emap

#if MIN_VERSION_base (4,8,0)
instance Bifunctor Gr where
  bimap :: forall a b c d. (a -> b) -> (c -> d) -> Gr a c -> Gr b d
bimap = forall (gr :: * -> * -> *) a c b d.
DynGraph gr =>
(a -> c) -> (b -> d) -> gr a b -> gr c d
nemap

  first :: forall a b c. (a -> b) -> Gr a c -> Gr b c
first = forall (gr :: * -> * -> *) a c b.
DynGraph gr =>
(a -> c) -> gr a b -> gr c b
nmap

  second :: forall b c a. (b -> c) -> Gr a b -> Gr a c
second = forall (gr :: * -> * -> *) b c a.
DynGraph gr =>
(b -> c) -> gr a b -> gr a c
emap
#endif

----------------------------------------------------------------------
-- UTILITIES
----------------------------------------------------------------------

addSucc :: Node -> b -> Context' a b -> Context' a b
addSucc :: forall b a. Node -> b -> Context' a b -> Context' a b
addSucc Node
v b
l (Adj b
p,a
l',Adj b
s) = (Adj b
p,a
l',(b
l,Node
v)forall a. a -> [a] -> [a]
:Adj b
s)

addPred :: Node -> b -> Context' a b -> Context' a b
addPred :: forall b a. Node -> b -> Context' a b -> Context' a b
addPred Node
v b
l (Adj b
p,a
l',Adj b
s) = ((b
l,Node
v)forall a. a -> [a] -> [a]
:Adj b
p,a
l',Adj b
s)

clearSucc :: Node -> b -> Context' a b -> Context' a b
clearSucc :: forall b a. Node -> b -> Context' a b -> Context' a b
clearSucc Node
v b
_ (Adj b
p,a
l,Adj b
s) = (Adj b
p,a
l,forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=Node
v)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> b
snd) Adj b
s)

clearPred :: Node -> b -> Context' a b -> Context' a b
clearPred :: forall b a. Node -> b -> Context' a b -> Context' a b
clearPred Node
v b
_ (Adj b
p,a
l,Adj b
s) = (forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=Node
v)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a b. (a, b) -> b
snd) Adj b
p,a
l,Adj b
s)

updAdj :: Adj b -> (b -> Context' a b -> Context' a b) -> GraphRep a b -> GraphRep a b
updAdj :: forall b a.
Adj b
-> (b -> Context' a b -> Context' a b)
-> GraphRep a b
-> GraphRep a b
updAdj Adj b
adj b -> Context' a b -> Context' a b
f GraphRep a b
g = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\GraphRep a b
g' (b
l,Node
v) -> forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
M.adjust (b -> Context' a b -> Context' a b
f b
l) Node
v GraphRep a b
g') GraphRep a b
g Adj b
adj