-- | A structure representing unique vertices and their interrelations
module Mini.Data.Graph (
  -- * A Note on Performance
  -- $note

  -- * Type
  Graph,

  -- * Primitive Recursion
  graph,

  -- * Algorithms
  distance,
  layers,
  path,
  reachable,
  sort,

  -- * Construction
  empty,
  fromList,
  singleton,

  -- * Modification
  add,
  remove,
  connect,
  disconnect,
  transpose,

  -- * Query
  assocs,
  edges,
  vertices,
  indegree,
  indegrees,
  outdegree,
  outdegrees,
  lookup,
  lookupGE,
  lookupGT,
  lookupLE,
  lookupLT,
  lookupMax,
  lookupMin,
  member,
  sourceMax,
  sourceMin,
  sources,
  sinkMax,
  sinkMin,
  sinks,
) where

import Data.Bifunctor (
  second,
 )
import Data.Bool (
  bool,
 )
import Data.List (
  unfoldr,
 )
import Mini.Data.Map (
  Map,
 )
import qualified Mini.Data.Map as Map (
  delete,
  empty,
  foldlWithKey,
  foldrWithKey,
  insertWith,
  lookup,
  lookupGE,
  lookupGT,
  lookupLE,
  lookupLT,
  lookupMax,
  lookupMin,
  member,
  singleton,
  toAscList,
  unionWith,
 )
import Mini.Data.Set (
  Set,
 )
import qualified Mini.Data.Set as Set (
  delete,
  difference,
  empty,
  fromList,
  member,
  null,
  singleton,
  size,
  toAscList,
 )
import Prelude (
  Bool,
  Eq,
  Foldable,
  Int,
  Maybe (
    Just,
    Nothing
  ),
  Monoid,
  Ord,
  Semigroup,
  Show,
  any,
  compare,
  concat,
  flip,
  fmap,
  foldMap,
  foldr,
  fst,
  maybe,
  mempty,
  show,
  uncurry,
  ($),
  (+),
  (.),
  (<$>),
  (<>),
  (==),
 )

{-
 - A Note on Performance
 -}

{- $note
In order to provide a friendly user interface, some performance has been
sacrificed. The internal adjacency lists are implemented via maps rather than
arrays, meaning accesses are done in logarithmic time rather than constant time.
-}

{-
 - Type
 -}

-- | A graph with directed edges between vertices of type /a/
data Graph a
  = Graph
      (Map a (Set a))
      (Map a (Set a))

instance (Eq a) => Eq (Graph a) where
  (Graph Map a (Set a)
_ Map a (Set a)
oes1) == :: Graph a -> Graph a -> Bool
== (Graph Map a (Set a)
_ Map a (Set a)
oes2) = Map a (Set a)
oes1 Map a (Set a) -> Map a (Set a) -> Bool
forall a. Eq a => a -> a -> Bool
== Map a (Set a)
oes2

instance (Ord a) => Ord (Graph a) where
  compare :: Graph a -> Graph a -> Ordering
compare (Graph Map a (Set a)
_ Map a (Set a)
oes1) (Graph Map a (Set a)
_ Map a (Set a)
oes2) = Map a (Set a) -> Map a (Set a) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Map a (Set a)
oes1 Map a (Set a)
oes2

instance (Show a) => Show (Graph a) where
  show :: Graph a -> String
show = [(a, [a])] -> String
forall a. Show a => a -> String
show ([(a, [a])] -> String)
-> (Graph a -> [(a, [a])]) -> Graph a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph a -> [(a, [a])]
forall a. Graph a -> [(a, [a])]
assocs

instance Foldable Graph where
  foldr :: forall a b. (a -> b -> b) -> b -> Graph a -> b
foldr a -> b -> b
f b
b = (a -> b -> b) -> b -> [a] -> b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> b -> b
f b
b ([a] -> b) -> (Graph a -> [a]) -> Graph a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph a -> [a]
forall a. Graph a -> [a]
vertices

instance (Ord a) => Semigroup (Graph a) where
  (Graph Map a (Set a)
ies1 Map a (Set a)
oes1) <> :: Graph a -> Graph a -> Graph a
<> (Graph Map a (Set a)
ies2 Map a (Set a)
oes2) =
    Map a (Set a) -> Map a (Set a) -> Graph a
forall a. Map a (Set a) -> Map a (Set a) -> Graph a
Graph
      ((Set a -> Set a -> Set a)
-> Map a (Set a) -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set a -> Set a -> Set a
forall a. Semigroup a => a -> a -> a
(<>) Map a (Set a)
ies1 Map a (Set a)
ies2)
      ((Set a -> Set a -> Set a)
-> Map a (Set a) -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set a -> Set a -> Set a
forall a. Semigroup a => a -> a -> a
(<>) Map a (Set a)
oes1 Map a (Set a)
oes2)

instance (Ord a) => Monoid (Graph a) where
  mempty :: Graph a
mempty = Graph a
forall a. Graph a
empty

{-
 - Primitive Recursion
 -}

-- | Primitive recursion on graphs (internally represented by adjacency lists)
graph
  :: (Map a (Set a) -> Map a (Set a) -> b)
  -- ^ Function applied to the adjacency lists of the graph:
  -- incoming edges, outgoing edges
  -> Graph a
  -- ^ The graph
  -> b
graph :: forall a b. (Map a (Set a) -> Map a (Set a) -> b) -> Graph a -> b
graph Map a (Set a) -> Map a (Set a) -> b
f (Graph Map a (Set a)
ies Map a (Set a)
oes) = Map a (Set a) -> Map a (Set a) -> b
f Map a (Set a)
ies Map a (Set a)
oes

{-
 - Algorithms
 -}

-- | Get the shortest distance in a graph between a vertex and another
distance :: (Ord a) => Graph a -> a -> a -> Maybe Int
distance :: forall a. Ord a => Graph a -> a -> a -> Maybe Int
distance Graph a
g a
s a
t =
  (Set a -> Maybe Int -> Maybe Int)
-> Maybe Int -> [Set a] -> Maybe Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
    (\Set a
a Maybe Int
b -> Maybe Int -> Maybe Int -> Bool -> Maybe Int
forall a. a -> a -> Bool -> a
bool ((Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
b) (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) (Bool -> Maybe Int) -> Bool -> Maybe Int
forall a b. (a -> b) -> a -> b
$ a
t a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
a)
    Maybe Int
forall a. Maybe a
Nothing
    ([Set a] -> Maybe Int) -> [Set a] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Graph a -> a -> [Set a]
forall a. Ord a => Graph a -> a -> [Set a]
bfs Graph a
g a
s

-- | Breadth-first search for the hierarchy in a graph from a starting vertex
layers :: (Ord a) => Graph a -> a -> [[a]]
layers :: forall a. Ord a => Graph a -> a -> [[a]]
layers Graph a
g = (Set a -> [a]) -> [Set a] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Set a -> [a]
forall a. Set a -> [a]
Set.toAscList ([Set a] -> [[a]]) -> (a -> [Set a]) -> a -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph a -> a -> [Set a]
forall a. Ord a => Graph a -> a -> [Set a]
bfs Graph a
g

-- | Check whether there is a path in a graph from a vertex to another
path :: (Ord a) => Graph a -> a -> a -> Bool
path :: forall a. Ord a => Graph a -> a -> a -> Bool
path Graph a
g a
s a
t = (Set a -> Bool) -> [Set a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a
t a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member`) ([Set a] -> Bool) -> [Set a] -> Bool
forall a b. (a -> b) -> a -> b
$ Graph a -> a -> [Set a]
forall a. Ord a => Graph a -> a -> [Set a]
bfs Graph a
g a
s

-- | Get the reachable vertices in a graph from a starting vertex
reachable :: (Ord a) => Graph a -> a -> [a]
reachable :: forall a. Ord a => Graph a -> a -> [a]
reachable Graph a
g = [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> (a -> [[a]]) -> a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph a -> a -> [[a]]
forall a. Ord a => Graph a -> a -> [[a]]
layers Graph a
g

-- | Topologically sort a graph (assumes acyclicity)
sort :: (Ord a) => Graph a -> [a]
sort :: forall a. Ord a => Graph a -> [a]
sort = (Graph a -> Maybe (a, Graph a)) -> Graph a -> [a]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr ((Graph a -> Maybe (a, Graph a)) -> Graph a -> [a])
-> (Graph a -> Maybe (a, Graph a)) -> Graph a -> [a]
forall a b. (a -> b) -> a -> b
$ \Graph a
g -> (\a
u -> (a
u, a -> Graph a -> Graph a
forall a. Ord a => a -> Graph a -> Graph a
remove a
u Graph a
g)) (a -> (a, Graph a)) -> Maybe a -> Maybe (a, Graph a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Graph a -> Maybe a
forall a. Graph a -> Maybe a
sourceMin Graph a
g

{-
 - Construction
 -}

-- | The empty graph
empty :: Graph a
empty :: forall a. Graph a
empty = Map a (Set a) -> Map a (Set a) -> Graph a
forall a. Map a (Set a) -> Map a (Set a) -> Graph a
Graph Map a (Set a)
forall k a. Map k a
Map.empty Map a (Set a)
forall k a. Map k a
Map.empty

-- | Make a graph from a list of vertex associations
fromList :: (Ord a) => [(a, [a])] -> Graph a
fromList :: forall a. Ord a => [(a, [a])] -> Graph a
fromList = ((a, [a]) -> Graph a -> Graph a)
-> Graph a -> [(a, [a])] -> Graph 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] -> Graph a -> Graph a) -> (a, [a]) -> Graph a -> Graph a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> [a] -> Graph a -> Graph a
forall a. Ord a => a -> [a] -> Graph a -> Graph a
connect) Graph a
forall a. Graph a
empty

-- | Make a graph with an isolated vertex
singleton :: a -> Graph a
singleton :: forall a. a -> Graph a
singleton a
u = Map a (Set a) -> Map a (Set a) -> Graph a
forall a. Map a (Set a) -> Map a (Set a) -> Graph a
Graph (a -> Set a -> Map a (Set a)
forall k a. k -> a -> Map k a
Map.singleton a
u Set a
forall a. Set a
Set.empty) (a -> Set a -> Map a (Set a)
forall k a. k -> a -> Map k a
Map.singleton a
u Set a
forall a. Set a
Set.empty)

{-
 - Modification
 -}

-- | Add an isolated vertex to a graph unless already present
add :: (Ord a) => a -> Graph a -> Graph a
add :: forall a. Ord a => a -> Graph a -> Graph a
add a
u = a -> [a] -> Graph a -> Graph a
forall a. Ord a => a -> [a] -> Graph a -> Graph a
connect a
u []

-- | Remove a vertex and its associations from a graph
remove :: (Ord a) => a -> Graph a -> Graph a
remove :: forall a. Ord a => a -> Graph a -> Graph a
remove a
u (Graph Map a (Set a)
ies Map a (Set a)
oes) =
  Map a (Set a) -> Map a (Set a) -> Graph a
forall a. Map a (Set a) -> Map a (Set a) -> Graph a
Graph
    (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.delete a
u (Set a -> Set a) -> Map a (Set a) -> Map a (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
u Map a (Set a)
ies)
    (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.delete a
u (Set a -> Set a) -> Map a (Set a) -> Map a (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
u Map a (Set a)
oes)

-- | Add edges from a vertex to a list of vertices in a graph
connect :: (Ord a) => a -> [a] -> Graph a -> Graph a
connect :: forall a. Ord a => a -> [a] -> Graph a -> Graph a
connect a
u [a]
vs (Graph Map a (Set a)
ies Map a (Set a)
oes) =
  (Map a (Set a) -> Map a (Set a) -> Graph a)
-> (Map a (Set a), Map a (Set a)) -> Graph a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Map a (Set a) -> Map a (Set a) -> Graph a
forall a. Map a (Set a) -> Map a (Set a) -> Graph a
Graph ((Map a (Set a), Map a (Set a)) -> Graph a)
-> (Map a (Set a), Map a (Set a)) -> Graph a
forall a b. (a -> b) -> a -> b
$
    (a
 -> (Map a (Set a), Map a (Set a))
 -> (Map a (Set a), Map a (Set a)))
-> (Map a (Set a), Map a (Set a))
-> [a]
-> (Map a (Set a), Map a (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
      ( \a
v (Map a (Set a)
ies', Map a (Set a)
oes') ->
          ( (Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set a -> Set a -> Set a
forall a. Semigroup a => a -> a -> a
(<>) a
v (a -> Set a
forall a. a -> Set a
Set.singleton a
u) Map a (Set a)
ies'
          , (Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set a -> Set a -> Set a
forall a. Semigroup a => a -> a -> a
(<>) a
v Set a
forall a. Set a
Set.empty Map a (Set a)
oes'
          )
      )
      ( (Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set a -> Set a -> Set a
forall a. Semigroup a => a -> a -> a
(<>) a
u Set a
forall a. Set a
Set.empty Map a (Set a)
ies
      , (Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set a -> Set a -> Set a
forall a. Semigroup a => a -> a -> a
(<>) a
u ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
vs) Map a (Set a)
oes
      )
      [a]
vs

-- | Remove edges from a vertex to a list of vertices in a graph
disconnect :: (Ord a) => a -> [a] -> Graph a -> Graph a
disconnect :: forall a. Ord a => a -> [a] -> Graph a -> Graph a
disconnect a
u [a]
vs (Graph Map a (Set a)
ies Map a (Set a)
oes) =
  Map a (Set a) -> Map a (Set a) -> Graph a
forall a. Map a (Set a) -> Map a (Set a) -> Graph a
Graph
    ( (a -> Map a (Set a) -> Map a (Set a))
-> Map a (Set a) -> [a] -> Map a (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
        (\a
v -> (Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((Set a -> Set a -> Set a) -> Set a -> Set a -> Set a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.difference) a
v (Set a -> Map a (Set a) -> Map a (Set a))
-> Set a -> Map a (Set a) -> Map a (Set a)
forall a b. (a -> b) -> a -> b
$ a -> Set a
forall a. a -> Set a
Set.singleton a
u)
        Map a (Set a)
ies
        [a]
vs
    )
    ((Set a -> Set a -> Set a)
-> a -> Set a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((Set a -> Set a -> Set a) -> Set a -> Set a -> Set a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.difference) a
u ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
vs) Map a (Set a)
oes)

-- | Reverse the edges of a graph
transpose :: Graph a -> Graph a
transpose :: forall a. Graph a -> Graph a
transpose (Graph Map a (Set a)
ies Map a (Set a)
oes) = Map a (Set a) -> Map a (Set a) -> Graph a
forall a. Map a (Set a) -> Map a (Set a) -> Graph a
Graph Map a (Set a)
oes Map a (Set a)
ies

{-
 - Query
 -}

-- | Get the vertex associations of a graph
assocs :: Graph a -> [(a, [a])]
assocs :: forall a. Graph a -> [(a, [a])]
assocs (Graph Map a (Set a)
_ Map a (Set a)
oes) = (Set a -> [a]) -> (a, Set a) -> (a, [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Set a -> [a]
forall a. Set a -> [a]
Set.toAscList ((a, Set a) -> (a, [a])) -> [(a, Set a)] -> [(a, [a])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a (Set a) -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Set a)
oes

-- | Get the edges of a graph
edges :: Graph a -> [(a, a)]
edges :: forall a. Graph a -> [(a, a)]
edges (Graph Map a (Set a)
_ Map a (Set a)
oes) =
  (a -> Set a -> [(a, a)] -> [(a, a)])
-> [(a, a)] -> Map a (Set a) -> [(a, a)]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
    (\a
u -> ([(a, a)] -> Set a -> [(a, a)]) -> Set a -> [(a, a)] -> [(a, a)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (([(a, a)] -> Set a -> [(a, a)]) -> Set a -> [(a, a)] -> [(a, a)])
-> ([(a, a)] -> Set a -> [(a, a)]) -> Set a -> [(a, a)] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ (a -> [(a, a)] -> [(a, a)]) -> [(a, a)] -> Set a -> [(a, a)]
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
v -> (:) (a
u, a
v)))
    []
    Map a (Set a)
oes

-- | Get the vertices of a graph
vertices :: Graph a -> [a]
vertices :: forall a. Graph a -> [a]
vertices (Graph Map a (Set a)
_ Map a (Set a)
oes) = (a, Set a) -> a
forall a b. (a, b) -> a
fst ((a, Set a) -> a) -> [(a, Set a)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a (Set a) -> [(a, Set a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Set a)
oes

-- | Get the number of incoming edges to a vertex in a graph
indegree :: (Ord a) => a -> Graph a -> Maybe Int
indegree :: forall a. Ord a => a -> Graph a -> Maybe Int
indegree a
v (Graph Map a (Set a)
ies Map a (Set a)
_) = Set a -> Int
forall a. Set a -> Int
Set.size (Set a -> Int) -> Maybe (Set a) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set a) -> Maybe (Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
v Map a (Set a)
ies

-- | Get the number of incoming edges of each vertex in a graph
indegrees :: Graph a -> [(a, Int)]
indegrees :: forall a. Graph a -> [(a, Int)]
indegrees (Graph Map a (Set a)
ies Map a (Set a)
_) = Map a Int -> [(a, Int)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map a Int -> [(a, Int)]) -> Map a Int -> [(a, Int)]
forall a b. (a -> b) -> a -> b
$ Set a -> Int
forall a. Set a -> Int
Set.size (Set a -> Int) -> Map a (Set a) -> Map a Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a (Set a)
ies

-- | Get the number of outgoing edges from a vertex in a graph
outdegree :: (Ord a) => a -> Graph a -> Maybe Int
outdegree :: forall a. Ord a => a -> Graph a -> Maybe Int
outdegree a
u (Graph Map a (Set a)
_ Map a (Set a)
oes) = Set a -> Int
forall a. Set a -> Int
Set.size (Set a -> Int) -> Maybe (Set a) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set a) -> Maybe (Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
u Map a (Set a)
oes

-- | Get the number of outgoing edges of each vertex in a graph
outdegrees :: Graph a -> [(a, Int)]
outdegrees :: forall a. Graph a -> [(a, Int)]
outdegrees (Graph Map a (Set a)
_ Map a (Set a)
oes) = Map a Int -> [(a, Int)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map a Int -> [(a, Int)]) -> Map a Int -> [(a, Int)]
forall a b. (a -> b) -> a -> b
$ Set a -> Int
forall a. Set a -> Int
Set.size (Set a -> Int) -> Map a (Set a) -> Map a Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a (Set a)
oes

-- | Get the associations of a vertex from a graph
lookup :: (Ord a) => a -> Graph a -> Maybe [a]
lookup :: forall a. Ord a => a -> Graph a -> Maybe [a]
lookup a
u (Graph Map a (Set a)
_ Map a (Set a)
oes) = Set a -> [a]
forall a. Set a -> [a]
Set.toAscList (Set a -> [a]) -> Maybe (Set a) -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set a) -> Maybe (Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
u Map a (Set a)
oes

-- | Get the associations of the least vertex greater than or equal to a vertex
lookupGE :: (Ord a) => a -> Graph a -> Maybe (a, [a])
lookupGE :: forall a. Ord a => a -> Graph a -> Maybe (a, [a])
lookupGE a
a (Graph Map a (Set a)
_ Map a (Set a)
oes) = (Set a -> [a]) -> (a, Set a) -> (a, [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Set a -> [a]
forall a. Set a -> [a]
Set.toAscList ((a, Set a) -> (a, [a])) -> Maybe (a, Set a) -> Maybe (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set a) -> Maybe (a, Set a)
forall k a. Ord k => k -> Map k a -> Maybe (k, a)
Map.lookupGE a
a Map a (Set a)
oes

-- | Get the associations of the least vertex strictly greater than a vertex
lookupGT :: (Ord a) => a -> Graph a -> Maybe (a, [a])
lookupGT :: forall a. Ord a => a -> Graph a -> Maybe (a, [a])
lookupGT a
a (Graph Map a (Set a)
_ Map a (Set a)
oes) = (Set a -> [a]) -> (a, Set a) -> (a, [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Set a -> [a]
forall a. Set a -> [a]
Set.toAscList ((a, Set a) -> (a, [a])) -> Maybe (a, Set a) -> Maybe (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set a) -> Maybe (a, Set a)
forall k a. Ord k => k -> Map k a -> Maybe (k, a)
Map.lookupGT a
a Map a (Set a)
oes

-- | Get the associations of the greatest vertex less than or equal to a vertex
lookupLE :: (Ord a) => a -> Graph a -> Maybe (a, [a])
lookupLE :: forall a. Ord a => a -> Graph a -> Maybe (a, [a])
lookupLE a
a (Graph Map a (Set a)
_ Map a (Set a)
oes) = (Set a -> [a]) -> (a, Set a) -> (a, [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Set a -> [a]
forall a. Set a -> [a]
Set.toAscList ((a, Set a) -> (a, [a])) -> Maybe (a, Set a) -> Maybe (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set a) -> Maybe (a, Set a)
forall k a. Ord k => k -> Map k a -> Maybe (k, a)
Map.lookupLE a
a Map a (Set a)
oes

-- | Get the associations of the greatest vertex strictly less than a vertex
lookupLT :: (Ord a) => a -> Graph a -> Maybe (a, [a])
lookupLT :: forall a. Ord a => a -> Graph a -> Maybe (a, [a])
lookupLT a
a (Graph Map a (Set a)
_ Map a (Set a)
oes) = (Set a -> [a]) -> (a, Set a) -> (a, [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Set a -> [a]
forall a. Set a -> [a]
Set.toAscList ((a, Set a) -> (a, [a])) -> Maybe (a, Set a) -> Maybe (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Map a (Set a) -> Maybe (a, Set a)
forall k a. Ord k => k -> Map k a -> Maybe (k, a)
Map.lookupLT a
a Map a (Set a)
oes

-- | Get the associations of the maximum vertex from a graph
lookupMax :: Graph a -> Maybe (a, [a])
lookupMax :: forall a. Graph a -> Maybe (a, [a])
lookupMax (Graph Map a (Set a)
_ Map a (Set a)
oes) = (Set a -> [a]) -> (a, Set a) -> (a, [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Set a -> [a]
forall a. Set a -> [a]
Set.toAscList ((a, Set a) -> (a, [a])) -> Maybe (a, Set a) -> Maybe (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a (Set a) -> Maybe (a, Set a)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map a (Set a)
oes

-- | Get the associations of the minimum vertex from a graph
lookupMin :: Graph a -> Maybe (a, [a])
lookupMin :: forall a. Graph a -> Maybe (a, [a])
lookupMin (Graph Map a (Set a)
_ Map a (Set a)
oes) = (Set a -> [a]) -> (a, Set a) -> (a, [a])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Set a -> [a]
forall a. Set a -> [a]
Set.toAscList ((a, Set a) -> (a, [a])) -> Maybe (a, Set a) -> Maybe (a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map a (Set a) -> Maybe (a, Set a)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMin Map a (Set a)
oes

-- | Check whether a vertex is in a graph
member :: (Ord a) => a -> Graph a -> Bool
member :: forall a. Ord a => a -> Graph a -> Bool
member a
u (Graph Map a (Set a)
_ Map a (Set a)
oes) = a
u a -> Map a (Set a) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map a (Set a)
oes

-- | Get the maximum vertex with no incoming edges from a graph
sourceMax :: Graph a -> Maybe a
sourceMax :: forall a. Graph a -> Maybe a
sourceMax (Graph Map a (Set a)
ies Map a (Set a)
_) =
  (Maybe a -> a -> Set a -> Maybe a)
-> Maybe a -> Map a (Set a) -> Maybe a
forall b k a. (b -> k -> a -> b) -> b -> Map k a -> b
Map.foldlWithKey
    ( \Maybe a
b a
k ->
        Maybe a -> Maybe a -> Bool -> Maybe a
forall a. a -> a -> Bool -> a
bool
          Maybe a
b
          (a -> Maybe a
forall a. a -> Maybe a
Just a
k)
          (Bool -> Maybe a) -> (Set a -> Bool) -> Set a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Bool
forall a. Set a -> Bool
Set.null
    )
    Maybe a
forall a. Maybe a
Nothing
    Map a (Set a)
ies

-- | Get the minimum vertex with no incoming edges from a graph
sourceMin :: Graph a -> Maybe a
sourceMin :: forall a. Graph a -> Maybe a
sourceMin (Graph Map a (Set a)
ies Map a (Set a)
_) =
  (a -> Set a -> Maybe a -> Maybe a)
-> Maybe a -> Map a (Set a) -> Maybe a
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
    ( \a
k Set a
a Maybe a
b ->
        Maybe a -> Maybe a -> Bool -> Maybe a
forall a. a -> a -> Bool -> a
bool
          Maybe a
b
          (a -> Maybe a
forall a. a -> Maybe a
Just a
k)
          (Bool -> Maybe a) -> Bool -> Maybe a
forall a b. (a -> b) -> a -> b
$ Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
a
    )
    Maybe a
forall a. Maybe a
Nothing
    Map a (Set a)
ies

-- | Get the vertices with no incoming edges from a graph
sources :: Graph a -> [a]
sources :: forall a. Graph a -> [a]
sources (Graph Map a (Set a)
ies Map a (Set a)
_) =
  (a -> Set a -> [a] -> [a]) -> [a] -> Map a (Set a) -> [a]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
    ( \a
k Set a
a [a]
b ->
        [a] -> [a] -> Bool -> [a]
forall a. a -> a -> Bool -> a
bool
          [a]
b
          (a
k a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
b)
          (Bool -> [a]) -> Bool -> [a]
forall a b. (a -> b) -> a -> b
$ Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
a
    )
    []
    Map a (Set a)
ies

-- | Get the maximum vertex with no outgoing edges from a graph
sinkMax :: Graph a -> Maybe a
sinkMax :: forall a. Graph a -> Maybe a
sinkMax (Graph Map a (Set a)
_ Map a (Set a)
oes) =
  (Maybe a -> a -> Set a -> Maybe a)
-> Maybe a -> Map a (Set a) -> Maybe a
forall b k a. (b -> k -> a -> b) -> b -> Map k a -> b
Map.foldlWithKey
    ( \Maybe a
b a
k ->
        Maybe a -> Maybe a -> Bool -> Maybe a
forall a. a -> a -> Bool -> a
bool
          Maybe a
b
          (a -> Maybe a
forall a. a -> Maybe a
Just a
k)
          (Bool -> Maybe a) -> (Set a -> Bool) -> Set a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Bool
forall a. Set a -> Bool
Set.null
    )
    Maybe a
forall a. Maybe a
Nothing
    Map a (Set a)
oes

-- | Get the minimum vertex with no outgoing edges from a graph
sinkMin :: Graph a -> Maybe a
sinkMin :: forall a. Graph a -> Maybe a
sinkMin (Graph Map a (Set a)
_ Map a (Set a)
oes) =
  (a -> Set a -> Maybe a -> Maybe a)
-> Maybe a -> Map a (Set a) -> Maybe a
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
    ( \a
k Set a
a Maybe a
b ->
        Maybe a -> Maybe a -> Bool -> Maybe a
forall a. a -> a -> Bool -> a
bool
          Maybe a
b
          (a -> Maybe a
forall a. a -> Maybe a
Just a
k)
          (Bool -> Maybe a) -> Bool -> Maybe a
forall a b. (a -> b) -> a -> b
$ Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
a
    )
    Maybe a
forall a. Maybe a
Nothing
    Map a (Set a)
oes

-- | Get the vertices with no outgoing edges from a graph
sinks :: Graph a -> [a]
sinks :: forall a. Graph a -> [a]
sinks (Graph Map a (Set a)
_ Map a (Set a)
oes) =
  (a -> Set a -> [a] -> [a]) -> [a] -> Map a (Set a) -> [a]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey
    ( \a
k Set a
a [a]
b ->
        [a] -> [a] -> Bool -> [a]
forall a. a -> a -> Bool -> a
bool
          [a]
b
          (a
k a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
b)
          (Bool -> [a]) -> Bool -> [a]
forall a b. (a -> b) -> a -> b
$ Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
a
    )
    []
    Map a (Set a)
oes

{-
 - Helpers
 -}

-- | Breadth-first search for the hierarchy in a graph from a starting vertex
bfs :: (Ord a) => Graph a -> a -> [Set a]
bfs :: forall a. Ord a => Graph a -> a -> [Set a]
bfs (Graph Map a (Set a)
_ Map a (Set a)
oes) a
s =
  (Set a -> [Set a]) -> Maybe (Set a) -> [Set a]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
    ( \Set a
vs ->
        a -> Set a
forall a. a -> Set a
Set.singleton a
s
          Set a -> [Set a] -> [Set a]
forall a. a -> [a] -> [a]
: (((Set a, Map a (Set a)), Set a)
 -> Maybe (Set a, ((Set a, Map a (Set a)), Set a)))
-> ((Set a, Map a (Set a)), Set a) -> [Set a]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr
            ( \((Set a
us, Map a (Set a)
es), Set a
ds) ->
                Maybe (Set a, ((Set a, Map a (Set a)), Set a))
-> Maybe (Set a, ((Set a, Map a (Set a)), Set a))
-> Bool
-> Maybe (Set a, ((Set a, Map a (Set a)), Set a))
forall a. a -> a -> Bool -> a
bool
                  ( (Set a, ((Set a, Map a (Set a)), Set a))
-> Maybe (Set a, ((Set a, Map a (Set a)), Set a))
forall a. a -> Maybe a
Just
                      ( Set a
us
                      ,
                        ( (a -> (Set a, Map a (Set a)) -> (Set a, Map a (Set a)))
-> (Set a, Map a (Set a)) -> Set a -> (Set a, Map a (Set a))
forall a b. (a -> b -> b) -> b -> Set a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                            ( \a
u b :: (Set a, Map a (Set a))
b@(Set a
us', Map a (Set a)
es') ->
                                (Set a, Map a (Set a))
-> (Set a -> (Set a, Map a (Set a)))
-> Maybe (Set a)
-> (Set a, Map a (Set a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                                  (Set a, Map a (Set a))
b
                                  ( \Set a
vs' ->
                                      ( (Set a
us' Set a -> Set a -> Set a
forall a. Semigroup a => a -> a -> a
<> Set a
vs') Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set a
ds
                                      , a -> Map a (Set a) -> Map a (Set a)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
u Map a (Set a)
es'
                                      )
                                  )
                                  (Maybe (Set a) -> (Set a, Map a (Set a)))
-> Maybe (Set a) -> (Set a, Map a (Set a))
forall a b. (a -> b) -> a -> b
$ a -> Map a (Set a) -> Maybe (Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
u Map a (Set a)
es
                            )
                            (Set a
forall a. Set a
Set.empty, Map a (Set a)
es)
                            Set a
us
                        , Set a
ds Set a -> Set a -> Set a
forall a. Semigroup a => a -> a -> a
<> Set a
us
                        )
                      )
                  )
                  Maybe (Set a, ((Set a, Map a (Set a)), Set a))
forall a. Maybe a
Nothing
                  (Bool -> Maybe (Set a, ((Set a, Map a (Set a)), Set a)))
-> Bool -> Maybe (Set a, ((Set a, Map a (Set a)), Set a))
forall a b. (a -> b) -> a -> b
$ Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
us
            )
            ((Set a
vs, Map a (Set a)
oes), a -> Set a
forall a. a -> Set a
Set.singleton a
s)
    )
    (Maybe (Set a) -> [Set a]) -> Maybe (Set a) -> [Set a]
forall a b. (a -> b) -> a -> b
$ a -> Map a (Set a) -> Maybe (Set a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
s Map a (Set a)
oes