{-# LANGUAGE GADTs #-}

module HGraph.Directed
       ( DirectedGraph(..)
       , Adjacency(..)
       , Mutable(..)
       , subgraphAround
       , renameVertices
       , topologicalOrdering
       , inducedSubgraph
       , lineDigraphI
       , transitiveClosure
       , isIsomorphicTo
       , isIsomorphicToI
       , splitVertices
       , union
       )
where

import qualified Data.Map as M
import qualified Data.Set as S
import HGraph.Utils
import Data.Maybe

class DirectedGraph t where
  empty :: t a -> t a
  vertices :: t a -> [a]
  numVertices :: Integral b => t a -> b
  numVertices t a
d = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
  arcs :: t a -> [(a,a)]
  numArcs :: Integral b => t a -> b
  numArcs t a
d = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ [(a, a)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(a, a)] -> Int) -> [(a, a)] -> Int
forall a b. (a -> b) -> a -> b
$ t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d
  linearizeVertices :: t a -> (t Int, [(Int, a)])
  isVertex :: t a -> a -> Bool

class Adjacency t where
  outneighbors :: t a -> a -> [a]
  inneighbors  :: t a -> a -> [a]
  outdegree :: Integral b => t a -> a -> b
  outdegree t a
d a
v = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v
  indegree :: Integral b => t a -> a -> b
  indegree t a
d a
v = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> [a] -> Int
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
v
  incomingArcs :: t a -> a -> [(a,a)]
  incomingArcs t a
d a
v = [(a
x,a
v) | a
x <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
v]
  outgoingArcs :: t a -> a -> [(a,a)]
  outgoingArcs t a
d a
v = [(a
v,a
x) | a
x <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v]
  arcExists :: t a -> (a,a) -> Bool
  metaBfs :: Ord a => t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a]
  metaBfs t a
d a
v [a] -> [a]
inFilter [a] -> [a]
outFilter =
    Set a -> Set a -> [a]
metaBfs' Set a
forall a. Set a
S.empty ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ ([a] -> [a]
inFilter ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
v) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ ([a] -> [a]
outFilter ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v))
    where
      metaBfs' :: Set a -> Set a -> [a]
metaBfs' Set a
visited Set a
toVisit = 
        let vs :: [a]
vs = Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
toVisit
            newToVisit :: Set a
newToVisit =
              ([Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions ([Set a] -> Set a) -> [Set a] -> Set a
forall a b. (a -> b) -> a -> b
$ (a -> Set a) -> [a] -> [Set a]
forall a b. (a -> b) -> [a] -> [b]
map
                ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> (a -> [a]) -> a -> Set a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
                  (\a
v -> ([a] -> [a]
inFilter ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
v) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ ([a] -> [a]
outFilter ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v)))
                [a]
vs
              )
              Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`S.difference` Set a
visited
        in if Set a -> Bool
forall a. Set a -> Bool
S.null Set a
newToVisit then [a]
vs else [a]
vs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ Set a -> Set a -> [a]
metaBfs' (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.union ([a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
vs) Set a
visited) Set a
newToVisit

class Mutable t where
  addVertex    :: a -> t a -> t a
  removeVertex :: a -> t a -> t a
  addArc    :: (a,a) -> t a -> t a
  removeArc :: (a,a) -> t a -> t a

renameVertices :: (DirectedGraph t, Mutable t, Ord a) => M.Map a b -> t b -> t a -> t b
renameVertices :: forall (t :: * -> *) a b.
(DirectedGraph t, Mutable t, Ord a) =>
Map a b -> t b -> t a -> t b
renameVertices Map a b
relabel t b
emptyD t a
d = 
  ((b, b) -> t b -> t b) -> t b -> [(b, b)] -> t b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (b, b) -> t b -> t b
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((b -> t b -> t b) -> t b -> [b] -> t b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr b -> t b -> t b
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex t b
emptyD ([b] -> t b) -> [b] -> t b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (Map a b
relabel Map a b -> a -> b
forall k a. Ord k => Map k a -> k -> a
M.!) ([a] -> [b]) -> [a] -> [b]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d)
               [(Map a b
relabel Map a b -> a -> b
forall k a. Ord k => Map k a -> k -> a
M.! a
v, Map a b
relabel Map a b -> a -> b
forall k a. Ord k => Map k a -> k -> a
M.! a
u) | (a
v,a
u) <- t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d]

subgraphAround :: (DirectedGraph t, Adjacency t, Mutable t) => Int -> t a -> a -> t a
subgraphAround :: forall (t :: * -> *) a.
(DirectedGraph t, Adjacency t, Mutable t) =>
Int -> t a -> a -> t a
subgraphAround Int
radius t a
d a
v = Int -> t a -> [a] -> t a
around Int
radius (a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex a
v (t a -> t a) -> t a -> t a
forall a b. (a -> b) -> a -> b
$ t a -> t a
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t a
d) [a
v]
  where
    around :: Int -> t a -> [a] -> t a
around Int
_ t a
h [] = t a
h
    around Int
0 t a
h [a]
_ = t a
h
    around Int
r t a
h [a]
us = Int -> t a -> [a] -> t a
around (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex t a
h [a]
ws) [(a, a)]
as) [a]
ws
      where
        ws :: [a]
ws = [a
w | a
u <- [a]
us, a
w <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
u [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
u, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ t a -> a -> Bool
forall a. t a -> a -> Bool
forall (t :: * -> *) a. DirectedGraph t => t a -> a -> Bool
isVertex t a
h a
w]
        as :: [(a, a)]
as = [(a
u,a
w) | a
u <- [a]
us, a
w <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
u] [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++
             [(a
w,a
u) | a
u <- [a]
us, a
w <- t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d a
u]

topologicalOrdering :: t a -> Maybe [a]
topologicalOrdering t a
d = 
  t a -> Set a -> Maybe [a]
forall {t :: * -> *} {a}.
(DirectedGraph t, Mutable t, Adjacency t, Ord a) =>
t a -> Set a -> Maybe [a]
ordering' t a
d (Set a -> Maybe [a]) -> Set a -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
sources
  where
    sources :: [a]
sources = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
v -> t a -> a -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
indegree t a
d a
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d
    ordering' :: t a -> Set a -> Maybe [a]
ordering' t a
d Set a
sources
      | t a -> Integer
forall b a. Integral b => t a -> b
forall (t :: * -> *) b a. (DirectedGraph t, Integral b) => t a -> b
numVertices t a
d Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 = [a] -> Maybe [a]
forall a. a -> Maybe a
Just []
      | Set a -> Bool
forall a. Set a -> Bool
S.null Set a
sources = Maybe [a]
forall a. Maybe a
Nothing
      | Bool
otherwise = 
        let d' :: t a
d' = ((a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
removeVertex t a
d ([a] -> t a) -> [a] -> t a
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
sources)
        in ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
sources) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++) (Maybe [a] -> Maybe [a]) -> Maybe [a] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ t a -> Set a -> Maybe [a]
ordering' t a
d' (Set a -> Maybe [a]) -> Set a -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ (a -> [a]) -> Set a -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\a
v -> (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
u -> t a -> a -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
indegree t a
d' a
u Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d a
v) Set a
sources

inducedSubgraph :: t a -> Set a -> t a
inducedSubgraph t a
d Set a
vs = 
  ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t a -> t a
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t a
d) ([a] -> t a) -> [a] -> t a
forall a b. (a -> b) -> a -> b
$ Set a -> [a]
forall a. Set a -> [a]
S.toList Set a
vs) [ (a
v,a
u) | (a
v,a
u) <- t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d, a
v a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
vs Bool -> Bool -> Bool
&& a
u a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
vs ]

transitiveClosure :: t t -> t t
transitiveClosure t t
d = 
  ((t, t) -> t t -> t t) -> t t -> [(t, t)] -> t t
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (t, t) -> t t -> t t
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((t -> t t -> t t) -> t t -> [t] -> t t
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr t -> t t -> t t
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t t -> t t
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t t
d) ([t] -> t t) -> [t] -> t t
forall a b. (a -> b) -> a -> b
$ t t -> [t]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t t
d) ([(t, t)] -> t t) -> [(t, t)] -> t t
forall a b. (a -> b) -> a -> b
$ [[(t, t)]] -> [(t, t)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ (t -> (t, t)) -> [t] -> [(t, t)]
forall a b. (a -> b) -> [a] -> [b]
map (\t
u -> (t
v,t
u)) ([t] -> [(t, t)]) -> [t] -> [(t, t)]
forall a b. (a -> b) -> a -> b
$ (t -> Bool) -> [t] -> [t]
forall a. (a -> Bool) -> [a] -> [a]
filter (t -> t -> Bool
forall a. Eq a => a -> a -> Bool
/=t
v) ([t] -> [t]) -> [t] -> [t]
forall a b. (a -> b) -> a -> b
$ t t -> t -> ([t] -> [t]) -> ([t] -> [t]) -> [t]
forall a. Ord a => t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a]
forall (t :: * -> *) a.
(Adjacency t, Ord a) =>
t a -> a -> ([a] -> [a]) -> ([a] -> [a]) -> [a]
metaBfs t t
d t
v (\[t]
_ -> []) [t] -> [t]
forall a. a -> a
id
    | t
v <- t t -> [t]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t t
d
    ]

-- | Find an isomorphism from `d0` to `d1`, if it exists.
isIsomorphicTo :: t a -> t a -> Bool
isIsomorphicTo t a
d0 t a
d1 = t Int -> t Int -> Bool
forall {t :: * -> *} {t :: * -> *} {a} {k}.
(Adjacency t, Adjacency t, DirectedGraph t, DirectedGraph t, Ord k,
 Ord a) =>
t k -> t a -> Bool
isIsomorphicToI t Int
d0i t Int
d1i
  where
    (t Int
d0i, [(Int, a)]
_) = t a -> (t Int, [(Int, a)])
forall a. t a -> (t Int, [(Int, a)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t a
d0
    (t Int
d1i, [(Int, a)]
_) = t a -> (t Int, [(Int, a)])
forall a. t a -> (t Int, [(Int, a)])
forall (t :: * -> *) a.
DirectedGraph t =>
t a -> (t Int, [(Int, a)])
linearizeVertices t a
d1

isIsomorphicToI :: t k -> t a -> Bool
isIsomorphicToI t k
d0 t a
d1 = Maybe (Map k a) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Map k a) -> Bool) -> Maybe (Map k a) -> Bool
forall a b. (a -> b) -> a -> b
$[k] -> Map k a -> Map k (Set a) -> Maybe (Map k a)
findIso (t k -> [k]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t k
d0) Map k a
forall k a. Map k a
M.empty Map k (Set a)
candidates0
  where
    candidates0 :: Map k (Set a)
candidates0 = [(k, Set a)] -> Map k (Set a)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                  [ (k
v, [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList [a]
us)
                  | k
v <- t k -> [k]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t k
d0
                  , let ov :: Integer
ov = t k -> k -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
outdegree t k
d0 k
v
                  , let iv :: Integer
iv = t k -> k -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
indegree t k
d0 k
v
                  , let us :: [a]
us = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\a
u -> t a -> a -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
outdegree t a
d1 a
u Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
ov Bool -> Bool -> Bool
&& t a -> a -> Integer
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
indegree t a
d1 a
u Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
iv) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d1
                  ]
    findIso :: [k] -> Map k a -> Map k (Set a) -> Maybe (Map k a)
findIso [] Map k a
phi Map k (Set a)
_ = Map k a -> Maybe (Map k a)
forall a. a -> Maybe a
Just Map k a
phi
    findIso (k
v:[k]
vs) Map k a
phi Map k (Set a)
candidates = [Map k a] -> Maybe (Map k a)
forall {a}. [a] -> Maybe a
mhead ([Map k a] -> Maybe (Map k a)) -> [Map k a] -> Maybe (Map k a)
forall a b. (a -> b) -> a -> b
$ (Maybe (Map k a) -> Map k a) -> [Maybe (Map k a)] -> [Map k a]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (Map k a) -> Map k a
forall a. HasCallStack => Maybe a -> a
fromJust ([Maybe (Map k a)] -> [Map k a]) -> [Maybe (Map k a)] -> [Map k a]
forall a b. (a -> b) -> a -> b
$ (Maybe (Map k a) -> Bool) -> [Maybe (Map k a)] -> [Maybe (Map k a)]
forall a. (a -> Bool) -> [a] -> [a]
filter Maybe (Map k a) -> Bool
forall a. Maybe a -> Bool
isJust ([Maybe (Map k a)] -> [Maybe (Map k a)])
-> [Maybe (Map k a)] -> [Maybe (Map k a)]
forall a b. (a -> b) -> a -> b
$ do      
      a
u <- Set a -> [a]
forall a. Set a -> [a]
S.toList (Set a -> [a]) -> Set a -> [a]
forall a b. (a -> b) -> a -> b
$ Map k (Set a)
candidates Map k (Set a) -> k -> Set a
forall k a. Ord k => Map k a -> k -> a
M.! k
v
      let phi' :: Map k a
phi' = k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
v a
u Map k a
phi
      let candidates' :: Map k (Set a)
candidates' = (Set a -> Set a) -> Map k (Set a) -> Map k (Set a)
forall a b k. (a -> b) -> Map k a -> Map k b
M.map (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.delete a
u) (Map k (Set a) -> Map k (Set a)) -> Map k (Set a) -> Map k (Set a)
forall a b. (a -> b) -> a -> b
$ k -> Map k (Set a) -> Map k (Set a)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete k
v (Map k (Set a) -> Map k (Set a)) -> Map k (Set a) -> Map k (Set a)
forall a b. (a -> b) -> a -> b
$ 
              ((k, Set a) -> Map k (Set a) -> Map k (Set a))
-> Map k (Set a) -> [(k, Set a)] -> Map k (Set a)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((k -> Set a -> Map k (Set a) -> Map k (Set a))
-> (k, Set a) -> Map k (Set a) -> Map k (Set a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((k -> Set a -> Map k (Set a) -> Map k (Set a))
 -> (k, Set a) -> Map k (Set a) -> Map k (Set a))
-> (k -> Set a -> Map k (Set a) -> Map k (Set a))
-> (k, Set a)
-> Map k (Set a)
-> Map k (Set a)
forall a b. (a -> b) -> a -> b
$ (Set a -> Set a -> Set a)
-> k -> Set a -> Map k (Set a) -> Map k (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\Set a
n Set a
o -> Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set a
n Set a
o) )
                    Map k (Set a)
candidates ([(k, Set a)] -> Map k (Set a)) -> [(k, Set a)] -> Map k (Set a)
forall a b. (a -> b) -> a -> b
$
                    [ (k
w, [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t a
d1 a
u)
                    | k
w <- t k -> k -> [k]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t k
d0 k
v
                    ] [(k, Set a)] -> [(k, Set a)] -> [(k, Set a)]
forall a. [a] -> [a] -> [a]
++
                    [ (k
w, [a] -> Set a
forall a. Ord a => [a] -> Set a
S.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ t a -> a -> [a]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t a
d1 a
u)
                    | k
w <- t k -> k -> [k]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
inneighbors t k
d0 k
v
                    ]
      if Map k (Set a) -> Bool
forall a. Map k a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Map k (Set a) -> Bool) -> Map k (Set a) -> Bool
forall a b. (a -> b) -> a -> b
$ (Set a -> Bool) -> Map k (Set a) -> Map k (Set a)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter Set a -> Bool
forall a. Set a -> Bool
S.null Map k (Set a)
candidates' then
        Maybe (Map k a) -> [Maybe (Map k a)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Map k a) -> [Maybe (Map k a)])
-> Maybe (Map k a) -> [Maybe (Map k a)]
forall a b. (a -> b) -> a -> b
$ [k] -> Map k a -> Map k (Set a) -> Maybe (Map k a)
findIso [k]
vs Map k a
phi' Map k (Set a)
candidates'
      else
        []

union :: t a -> t a -> t a
union t a
d0 t a
d1 = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex t a
d0 ([a] -> t a) -> [a] -> t a
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d1) ([(a, a)] -> t a) -> [(a, a)] -> t a
forall a b. (a -> b) -> a -> b
$ t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d1

-- | Split each vertex `v` of the digraph into two vertices `v_in` and `v_out`.
-- All incoming arcs of `v` become incoming arcs of `v_in`, all
-- outgoing arcs from `v` become outgoing arcs from `v_out` and there is an arc `(v_in, v_out)`.
--
-- This operation is useful when obtaining a vertex variant of arc-based algorithms like maximum flow.
splitVertices :: t a -> t a
splitVertices t a
d = t a
d''
  where
    d' :: t a
d'  = (a -> t a -> t a) -> t a -> [a] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> t a -> t a
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t a -> t a
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t a
d) ([[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v, a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
va -> a -> a
forall a. Num a => a -> a -> a
+a
1] | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d])
    d'' :: t a
d'' = ((a, a) -> t a -> t a) -> t a -> [(a, a)] -> t a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, a) -> t a -> t a
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc t a
d' ([(a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v, a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
v a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) | a
v <- t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t a
d] [(a, a)] -> [(a, a)] -> [(a, a)]
forall a. [a] -> [a] -> [a]
++ [(a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
va -> a -> a
forall a. Num a => a -> a -> a
+a
1, a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
u) | (a
v,a
u) <- t a -> [(a, a)]
forall a. t a -> [(a, a)]
forall (t :: * -> *) a. DirectedGraph t => t a -> [(a, a)]
arcs t a
d])


-- | The line digraph of a digraph `d` is the digraph `(V', A')`, where `V'` is the set of arcs of `d`
-- there is an arc (a,b) if the head of `b` in `d` is the same as the tail of `a` in `d`.
lineDigraphI :: (DirectedGraph t, Adjacency t, Mutable t) => t Int -> (t Int, [(Int, (Int, Int))])
lineDigraphI :: forall (t :: * -> *).
(DirectedGraph t, Adjacency t, Mutable t) =>
t Int -> (t Int, [(Int, (Int, Int))])
lineDigraphI t Int
d = 
  let outNeighborhoods :: Map Int [(Int, Int)]
outNeighborhoods = Int -> [Int] -> Map Int [(Int, Int)]
enumerateOutArcs Int
0 (t Int -> [Int]
forall a. t a -> [a]
forall (t :: * -> *) a. DirectedGraph t => t a -> [a]
vertices t Int
d)
      enumerateOutArcs :: Int -> [Int] -> Map Int [(Int, Int)]
enumerateOutArcs Int
_ [] = Map Int [(Int, Int)]
forall k a. Map k a
M.empty
      enumerateOutArcs Int
i (Int
v:[Int]
vs) = 
        let rest :: Map Int [(Int, Int)]
rest = Int -> [Int] -> Map Int [(Int, Int)]
enumerateOutArcs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (t Int -> Int -> Int
forall b a. Integral b => t a -> a -> b
forall (t :: * -> *) b a.
(Adjacency t, Integral b) =>
t a -> a -> b
outdegree t Int
d Int
v)) [Int]
vs
        in Int -> [(Int, Int)] -> Map Int [(Int, Int)] -> Map Int [(Int, Int)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
v ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
i..] (t Int -> Int -> [Int]
forall a. t a -> a -> [a]
forall (t :: * -> *) a. Adjacency t => t a -> a -> [a]
outneighbors t Int
d Int
v)) Map Int [(Int, Int)]
rest
      vs :: [Int]
vs = [Int
i | [(Int, Int)]
us <- ((Int, [(Int, Int)]) -> [(Int, Int)])
-> [(Int, [(Int, Int)])] -> [[(Int, Int)]]
forall a b. (a -> b) -> [a] -> [b]
map (Int, [(Int, Int)]) -> [(Int, Int)]
forall a b. (a, b) -> b
snd ([(Int, [(Int, Int)])] -> [[(Int, Int)]])
-> [(Int, [(Int, Int)])] -> [[(Int, Int)]]
forall a b. (a -> b) -> a -> b
$ Map Int [(Int, Int)] -> [(Int, [(Int, Int)])]
forall k a. Map k a -> [(k, a)]
M.assocs Map Int [(Int, Int)]
outNeighborhoods, Int
i <- ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> a
fst [(Int, Int)]
us]
  in
  (
    ((Int, Int) -> t Int -> t Int) -> t Int -> [(Int, Int)] -> t Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Int, Int) -> t Int -> t Int
forall a. (a, a) -> t a -> t a
forall (t :: * -> *) a. Mutable t => (a, a) -> t a -> t a
addArc ((Int -> t Int -> t Int) -> t Int -> [Int] -> t Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> t Int -> t Int
forall a. a -> t a -> t a
forall (t :: * -> *) a. Mutable t => a -> t a -> t a
addVertex (t Int -> t Int
forall a. t a -> t a
forall (t :: * -> *) a. DirectedGraph t => t a -> t a
empty t Int
d) [Int]
vs)
             [ (Int
i, Int
j)
             | (Int
v, [(Int, Int)]
us) <- Map Int [(Int, Int)] -> [(Int, [(Int, Int)])]
forall k a. Map k a -> [(k, a)]
M.assocs Map Int [(Int, Int)]
outNeighborhoods
             , (Int
i, Int
u) <- [(Int, Int)]
us
             , (Int
j, Int
w) <- Map Int [(Int, Int)]
outNeighborhoods Map Int [(Int, Int)] -> Int -> [(Int, Int)]
forall k a. Ord k => Map k a -> k -> a
M.! Int
u
             ]
  , [ (Int
i, (Int
v,Int
u))
    | (Int
v, [(Int, Int)]
us) <- Map Int [(Int, Int)] -> [(Int, [(Int, Int)])]
forall k a. Map k a -> [(k, a)]
M.assocs Map Int [(Int, Int)]
outNeighborhoods
    , (Int
i, Int
u) <- [(Int, Int)]
us
    ]
  )