-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.Labelled.AdjacencyMap
-- Copyright  : (c) Andrey Mokhov 2016-2022
-- License    : MIT (see the file LICENSE)
-- Maintainer : [email protected]
-- Stability  : experimental
--
-- __Alga__ is a library for algebraic construction and manipulation of graphs
-- in Haskell. See <https://github.com/snowleopard/alga-paper this paper> for the
-- motivation behind the library, the underlying theory, and implementation details.
--
-- This module defines the 'AdjacencyMap' data type for edge-labelled graphs, as
-- well as associated operations and algorithms. 'AdjacencyMap' is an instance
-- of the 'C.Graph' type class, which can be used for polymorphic graph
-- construction and manipulation.
-----------------------------------------------------------------------------
module Algebra.Graph.Labelled.AdjacencyMap (
    -- * Data structure
    AdjacencyMap, adjacencyMap,

    -- * Basic graph construction primitives
    empty, vertex, edge, (-<), (>-), overlay, connect, vertices, edges,
    overlays, fromAdjacencyMaps,

    -- * Relations on graphs
    isSubgraphOf,

    -- * Graph properties
    isEmpty, hasVertex, hasEdge, edgeLabel, vertexCount, edgeCount, vertexList,
    edgeList, vertexSet, edgeSet, preSet, postSet, skeleton,

    -- * Graph transformation
    removeVertex, removeEdge, replaceVertex, replaceEdge, transpose, gmap,
    emap, induce, induceJust,

    -- * Relational operations
    closure, reflexiveClosure, symmetricClosure, transitiveClosure,

    -- * Miscellaneous
    consistent
    ) where

import Control.DeepSeq
import Data.Maybe
import Data.Map (Map)
import Data.Monoid (Sum (..))
import Data.Set (Set, (\\))
import Data.String
import GHC.Generics

import Algebra.Graph.Label

import qualified Algebra.Graph.AdjacencyMap as AM
import qualified Algebra.Graph.ToGraph      as T

import qualified Data.IntSet     as IntSet
import qualified Data.Map.Strict as Map
import qualified Data.Set        as Set

-- | Edge-labelled graphs, where the type variable @e@ stands for edge labels.
-- For example, 'AdjacencyMap' @Bool@ @a@ is isomorphic to unlabelled graphs
-- defined in the top-level module "Algebra.Graph.AdjacencyMap", where @False@
-- and @True@ denote the lack of and the existence of an unlabelled edge,
-- respectively.
newtype AdjacencyMap e a = AM {
    -- | The /adjacency map/ of an edge-labelled graph: each vertex is
    -- associated with a map from its direct successors to the corresponding
    -- edge labels.
    forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap :: Map a (Map a e) } deriving (AdjacencyMap e a -> AdjacencyMap e a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall e a.
(Eq a, Eq e) =>
AdjacencyMap e a -> AdjacencyMap e a -> Bool
/= :: AdjacencyMap e a -> AdjacencyMap e a -> Bool
$c/= :: forall e a.
(Eq a, Eq e) =>
AdjacencyMap e a -> AdjacencyMap e a -> Bool
== :: AdjacencyMap e a -> AdjacencyMap e a -> Bool
$c== :: forall e a.
(Eq a, Eq e) =>
AdjacencyMap e a -> AdjacencyMap e a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall e a x. Rep (AdjacencyMap e a) x -> AdjacencyMap e a
forall e a x. AdjacencyMap e a -> Rep (AdjacencyMap e a) x
$cto :: forall e a x. Rep (AdjacencyMap e a) x -> AdjacencyMap e a
$cfrom :: forall e a x. AdjacencyMap e a -> Rep (AdjacencyMap e a) x
Generic, AdjacencyMap e a -> ()
forall a. (a -> ()) -> NFData a
forall e a. (NFData a, NFData e) => AdjacencyMap e a -> ()
rnf :: AdjacencyMap e a -> ()
$crnf :: forall e a. (NFData a, NFData e) => AdjacencyMap e a -> ()
NFData)

instance (Ord a, Show a, Ord e, Show e) => Show (AdjacencyMap e a) where
    showsPrec :: Int -> AdjacencyMap e a -> ShowS
showsPrec Int
p lam :: AdjacencyMap e a
lam@(AM Map a (Map a e)
m)
        | forall a. Set a -> Bool
Set.null Set a
vs = String -> ShowS
showString String
"empty"
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(e, a, a)]
es     = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => Set a -> ShowS
vshow Set a
vs
        | Set a
vs forall a. Eq a => a -> a -> Bool
== Set a
used  = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$ forall {a} {a} {a}.
(Show a, Show a, Show a) =>
[(a, a, a)] -> ShowS
eshow [(e, a, a)]
es
        | Bool
otherwise   = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
                            String -> ShowS
showString String
"overlay (" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => Set a -> ShowS
vshow (Set a
vs forall a. Ord a => Set a -> Set a -> Set a
\\ Set a
used) 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} {a} {a}.
(Show a, Show a, Show a) =>
[(a, a, a)] -> ShowS
eshow [(e, a, a)]
es forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")"
      where
        vs :: Set a
vs   = forall e a. AdjacencyMap e a -> Set a
vertexSet AdjacencyMap e a
lam
        es :: [(e, a, a)]
es   = forall e a. AdjacencyMap e a -> [(e, a, a)]
edgeList AdjacencyMap e a
lam
        used :: Set a
used = forall a e. Ord a => Map a (Map a e) -> Set a
referredToVertexSet Map a (Map a e)
m
        vshow :: Set a -> ShowS
vshow Set a
vs = case forall a. Set a -> [a]
Set.toAscList Set a
vs of
            [a
x] -> String -> ShowS
showString String
"vertex "   forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
x
            [a]
xs  -> String -> ShowS
showString String
"vertices " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [a]
xs
        eshow :: [(a, a, a)] -> ShowS
eshow [(a, a, a)]
es = case [(a, a, a)]
es of
            [(a
e, a
x, a
y)] -> String -> ShowS
showString String
"edge "  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
e 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 => Int -> a -> ShowS
showsPrec Int
11 a
x 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 => Int -> a -> ShowS
showsPrec Int
11 a
y
            [(a, a, a)]
xs          -> String -> ShowS
showString String
"edges " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 [(a, a, a)]
xs

instance (Ord e, Monoid e, Ord a) => Ord (AdjacencyMap e a) where
    compare :: AdjacencyMap e a -> AdjacencyMap e a -> Ordering
compare AdjacencyMap e a
x AdjacencyMap e a
y = forall a. Monoid a => [a] -> a
mconcat
        [ forall a. Ord a => a -> a -> Ordering
compare (forall e a. AdjacencyMap e a -> Int
vertexCount AdjacencyMap e a
x) (forall e a. AdjacencyMap e a -> Int
vertexCount AdjacencyMap e a
y)
        , forall a. Ord a => a -> a -> Ordering
compare (forall e a. AdjacencyMap e a -> Set a
vertexSet   AdjacencyMap e a
x) (forall e a. AdjacencyMap e a -> Set a
vertexSet   AdjacencyMap e a
y)
        , forall a. Ord a => a -> a -> Ordering
compare (forall e a. AdjacencyMap e a -> Int
edgeCount   AdjacencyMap e a
x) (forall e a. AdjacencyMap e a -> Int
edgeCount   AdjacencyMap e a
y)
        , forall a. Ord a => a -> a -> Ordering
compare (AdjacencyMap e a -> Set (a, a)
eSet        AdjacencyMap e a
x) (AdjacencyMap e a -> Set (a, a)
eSet        AdjacencyMap e a
y)
        , Ordering
cmp ]
      where
        eSet :: AdjacencyMap e a -> Set (a, a)
eSet = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (\(e
_, a
x, a
y) -> (a
x, a
y)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. (Eq a, Eq e) => AdjacencyMap e a -> Set (e, a, a)
edgeSet
        cmp :: Ordering
cmp | AdjacencyMap e a
x forall a. Eq a => a -> a -> Bool
== AdjacencyMap e a
y               = Ordering
EQ
            | forall e a.
(Eq e, Monoid e, Ord a) =>
[AdjacencyMap e a] -> AdjacencyMap e a
overlays [AdjacencyMap e a
x, AdjacencyMap e a
y] forall a. Eq a => a -> a -> Bool
== AdjacencyMap e a
y = Ordering
LT
            | Bool
otherwise            = forall a. Ord a => a -> a -> Ordering
compare AdjacencyMap e a
x AdjacencyMap e a
y

-- | __Note:__ this does not satisfy the usual ring laws; see 'AdjacencyMap'
-- for more details.
instance (Eq e, Dioid e, Num a, Ord a) => Num (AdjacencyMap e a) where
    fromInteger :: Integer -> AdjacencyMap e a
fromInteger = forall a e. a -> AdjacencyMap e a
vertex forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger
    + :: AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
(+)         = forall e a.
(Eq e, Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
overlay
    * :: AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
(*)         = forall e a.
(Eq e, Monoid e, Ord a) =>
e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
connect forall a. Monoid a => a
mempty
    signum :: AdjacencyMap e a -> AdjacencyMap e a
signum      = forall a b. a -> b -> a
const forall e a. AdjacencyMap e a
empty
    abs :: AdjacencyMap e a -> AdjacencyMap e a
abs         = forall a. a -> a
id
    negate :: AdjacencyMap e a -> AdjacencyMap e a
negate      = forall a. a -> a
id

instance IsString a => IsString (AdjacencyMap e a) where
    fromString :: String -> AdjacencyMap e a
fromString = forall a e. a -> AdjacencyMap e a
vertex forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

-- | Defined via 'overlay'.
instance (Ord a, Eq e, Monoid e) => Semigroup (AdjacencyMap e a) where
    <> :: AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
(<>) = forall e a.
(Eq e, Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
overlay

-- | Defined via 'overlay' and 'empty'.
instance (Ord a, Eq e, Monoid e) => Monoid (AdjacencyMap e a) where
    mempty :: AdjacencyMap e a
mempty = forall e a. AdjacencyMap e a
empty

-- TODO: Add tests.
-- | Defined via 'skeleton' and the 'T.ToGraph' instance of 'AM.AdjacencyMap'.
instance (Eq e, Monoid e, Ord a) => T.ToGraph (AdjacencyMap e a) where
    type ToVertex (AdjacencyMap e a) = a
    toGraph :: AdjacencyMap e a -> Graph (ToVertex (AdjacencyMap e a))
toGraph                    = forall t. ToGraph t => t -> Graph (ToVertex t)
T.toGraph forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton
    foldg :: forall r.
r
-> (ToVertex (AdjacencyMap e a) -> r)
-> (r -> r -> r)
-> (r -> r -> r)
-> AdjacencyMap e a
-> r
foldg r
e ToVertex (AdjacencyMap e a) -> r
v r -> r -> r
o r -> r -> r
c              = forall t r.
ToGraph t =>
r -> (ToVertex t -> r) -> (r -> r -> r) -> (r -> r -> r) -> t -> r
T.foldg r
e ToVertex (AdjacencyMap e a) -> r
v r -> r -> r
o r -> r -> r
c forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton
    isEmpty :: AdjacencyMap e a -> Bool
isEmpty                    = forall e a. AdjacencyMap e a -> Bool
isEmpty
    hasVertex :: Eq (ToVertex (AdjacencyMap e a)) =>
ToVertex (AdjacencyMap e a) -> AdjacencyMap e a -> Bool
hasVertex                  = forall a e. Ord a => a -> AdjacencyMap e a -> Bool
hasVertex
    hasEdge :: Eq (ToVertex (AdjacencyMap e a)) =>
ToVertex (AdjacencyMap e a)
-> ToVertex (AdjacencyMap e a) -> AdjacencyMap e a -> Bool
hasEdge                    = forall a e. Ord a => a -> a -> AdjacencyMap e a -> Bool
hasEdge
    vertexCount :: Ord (ToVertex (AdjacencyMap e a)) => AdjacencyMap e a -> Int
vertexCount                = forall e a. AdjacencyMap e a -> Int
vertexCount
    edgeCount :: Ord (ToVertex (AdjacencyMap e a)) => AdjacencyMap e a -> Int
edgeCount                  = forall e a. AdjacencyMap e a -> Int
edgeCount
    vertexList :: Ord (ToVertex (AdjacencyMap e a)) =>
AdjacencyMap e a -> [ToVertex (AdjacencyMap e a)]
vertexList                 = forall e a. AdjacencyMap e a -> [a]
vertexList
    vertexSet :: Ord (ToVertex (AdjacencyMap e a)) =>
AdjacencyMap e a -> Set (ToVertex (AdjacencyMap e a))
vertexSet                  = forall e a. AdjacencyMap e a -> Set a
vertexSet
    vertexIntSet :: (ToVertex (AdjacencyMap e a) ~ Int) => AdjacencyMap e a -> IntSet
vertexIntSet               = [Int] -> IntSet
IntSet.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> [a]
vertexList
    edgeList :: Ord (ToVertex (AdjacencyMap e a)) =>
AdjacencyMap e a
-> [(ToVertex (AdjacencyMap e a), ToVertex (AdjacencyMap e a))]
edgeList                   = forall t.
(ToGraph t, Ord (ToVertex t)) =>
t -> [(ToVertex t, ToVertex t)]
T.edgeList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton
    edgeSet :: Ord (ToVertex (AdjacencyMap e a)) =>
AdjacencyMap e a
-> Set (ToVertex (AdjacencyMap e a), ToVertex (AdjacencyMap e a))
edgeSet                    = forall t.
(ToGraph t, Ord (ToVertex t)) =>
t -> Set (ToVertex t, ToVertex t)
T.edgeSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton
    adjacencyList :: Ord (ToVertex (AdjacencyMap e a)) =>
AdjacencyMap e a
-> [(ToVertex (AdjacencyMap e a), [ToVertex (AdjacencyMap e a)])]
adjacencyList              = forall t.
(ToGraph t, Ord (ToVertex t)) =>
t -> [(ToVertex t, [ToVertex t])]
T.adjacencyList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton
    preSet :: Ord (ToVertex (AdjacencyMap e a)) =>
ToVertex (AdjacencyMap e a)
-> AdjacencyMap e a -> Set (ToVertex (AdjacencyMap e a))
preSet                     = forall a e. Ord a => a -> AdjacencyMap e a -> Set a
preSet
    postSet :: Ord (ToVertex (AdjacencyMap e a)) =>
ToVertex (AdjacencyMap e a)
-> AdjacencyMap e a -> Set (ToVertex (AdjacencyMap e a))
postSet                    = forall a e. Ord a => a -> AdjacencyMap e a -> Set a
postSet
    toAdjacencyMap :: Ord (ToVertex (AdjacencyMap e a)) =>
AdjacencyMap e a -> AdjacencyMap (ToVertex (AdjacencyMap e a))
toAdjacencyMap             = forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton
    toAdjacencyIntMap :: (ToVertex (AdjacencyMap e a) ~ Int) =>
AdjacencyMap e a -> AdjacencyIntMap
toAdjacencyIntMap          = forall t. (ToGraph t, ToVertex t ~ Int) => t -> AdjacencyIntMap
T.toAdjacencyIntMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton
    toAdjacencyMapTranspose :: Ord (ToVertex (AdjacencyMap e a)) =>
AdjacencyMap e a -> AdjacencyMap (ToVertex (AdjacencyMap e a))
toAdjacencyMapTranspose    = forall t.
(ToGraph t, Ord (ToVertex t)) =>
t -> AdjacencyMap (ToVertex t)
T.toAdjacencyMapTranspose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton
    toAdjacencyIntMapTranspose :: (ToVertex (AdjacencyMap e a) ~ Int) =>
AdjacencyMap e a -> AdjacencyIntMap
toAdjacencyIntMapTranspose = forall t. (ToGraph t, ToVertex t ~ Int) => t -> AdjacencyIntMap
T.toAdjacencyIntMapTranspose forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton

-- | Construct the /empty graph/.
--
-- @
-- 'isEmpty'     empty == True
-- 'hasVertex' x empty == False
-- 'vertexCount' empty == 0
-- 'edgeCount'   empty == 0
-- @
empty :: AdjacencyMap e a
empty :: forall e a. AdjacencyMap e a
empty = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall k a. Map k a
Map.empty

-- | Construct the graph comprising /a single isolated vertex/.
--
-- @
-- 'isEmpty'     (vertex x) == False
-- 'hasVertex' x (vertex y) == (x == y)
-- 'vertexCount' (vertex x) == 1
-- 'edgeCount'   (vertex x) == 0
-- @
vertex :: a -> AdjacencyMap e a
vertex :: forall a e. a -> AdjacencyMap e a
vertex a
x = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton a
x forall k a. Map k a
Map.empty

-- | Construct the graph comprising /a single edge/.
--
-- @
-- edge e    x y              == 'connect' e ('vertex' x) ('vertex' y)
-- edge 'zero' x y              == 'vertices' [x,y]
-- 'hasEdge'   x y (edge e x y) == (e /= 'zero')
-- 'edgeLabel' x y (edge e x y) == e
-- 'edgeCount'     (edge e x y) == if e == 'zero' then 0 else 1
-- 'vertexCount'   (edge e 1 1) == 1
-- 'vertexCount'   (edge e 1 2) == 2
-- @
edge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a
edge :: forall e a.
(Eq e, Monoid e, Ord a) =>
e -> a -> a -> AdjacencyMap e a
edge e
e a
x a
y | e
e forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
zero = forall a e. Ord a => [a] -> AdjacencyMap e a
vertices [a
x, a
y]
           | a
x forall a. Eq a => a -> a -> Bool
== a
y    = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton a
x (forall k a. k -> a -> Map k a
Map.singleton a
x e
e)
           | Bool
otherwise = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(a
x, forall k a. k -> a -> Map k a
Map.singleton a
y e
e), (a
y, forall k a. Map k a
Map.empty)]

-- | The left-hand part of a convenient ternary-ish operator @x-\<e\>-y@ for
-- creating labelled edges.
--
-- @
-- x -\<e\>- y == 'edge' e x y
-- @
(-<) :: a -> e -> (a, e)
a
g -< :: forall a e. a -> e -> (a, e)
-< e
e = (a
g, e
e)

-- | The right-hand part of a convenient ternary-ish operator @x-\<e\>-y@ for
-- creating labelled edges.
--
-- @
-- x -\<e\>- y == 'edge' e x y
-- @
(>-) :: (Eq e, Monoid e, Ord a) => (a, e) -> a -> AdjacencyMap e a
(a
x, e
e) >- :: forall e a.
(Eq e, Monoid e, Ord a) =>
(a, e) -> a -> AdjacencyMap e a
>- a
y = forall e a.
(Eq e, Monoid e, Ord a) =>
e -> a -> a -> AdjacencyMap e a
edge e
e a
x a
y

infixl 5 -<
infixl 5 >-

-- | /Overlay/ two graphs. This is a commutative, associative and idempotent
-- operation with the identity 'empty'.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- 'isEmpty'     (overlay x y) == 'isEmpty'   x   && 'isEmpty'   y
-- 'hasVertex' z (overlay x y) == 'hasVertex' z x || 'hasVertex' z y
-- 'vertexCount' (overlay x y) >= 'vertexCount' x
-- 'vertexCount' (overlay x y) <= 'vertexCount' x + 'vertexCount' y
-- 'edgeCount'   (overlay x y) >= 'edgeCount' x
-- 'edgeCount'   (overlay x y) <= 'edgeCount' x   + 'edgeCount' y
-- 'vertexCount' (overlay 1 2) == 2
-- 'edgeCount'   (overlay 1 2) == 0
-- @
--
-- Note: 'overlay' composes edges in parallel using the operator '<+>' with
-- 'zero' acting as the identity:
--
-- @
-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' 'zero' x y) == e
-- 'edgeLabel' x y $ overlay ('edge' e x y) ('edge' f    x y) == e '<+>' f
-- @
--
-- Furthermore, when applied to transitive graphs, 'overlay' composes edges in
-- sequence using the operator '<.>' with 'one' acting as the identity:
--
-- @
-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' 'one' y z)) == e
-- 'edgeLabel' x z $ 'transitiveClosure' (overlay ('edge' e x y) ('edge' f   y z)) == e '<.>' f
-- @
overlay :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
overlay :: forall e a.
(Eq e, Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
overlay (AM Map a (Map a e)
x) (AM Map a (Map a e)
y) = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall e a.
(Eq e, Monoid e, Ord a) =>
Map a e -> Map a e -> Map a e
nonZeroUnion Map a (Map a e)
x Map a (Map a e)
y

-- Union maps, removing zero elements from the result.
nonZeroUnion :: (Eq e, Monoid e, Ord a) => Map a e -> Map a e -> Map a e
nonZeroUnion :: forall e a.
(Eq e, Monoid e, Ord a) =>
Map a e -> Map a e -> Map a e
nonZeroUnion Map a e
x Map a e
y = forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
zero) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Monoid a => a -> a -> a
mappend Map a e
x Map a e
y

-- Drop all edges with zero labels.
trimZeroes :: (Eq e, Monoid e) => Map a (Map a e) -> Map a (Map a e)
trimZeroes :: forall e a. (Eq e, Monoid e) => Map a (Map a e) -> Map a (Map a e)
trimZeroes = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
zero))

-- | /Connect/ two graphs with edges labelled by a given label. When applied to
-- the same labels, this is an associative operation with the identity 'empty',
-- which distributes over 'overlay' and obeys the decomposition axiom.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory. Note that the
-- number of edges in the resulting graph is quadratic with respect to the
-- number of vertices of the arguments: /m = O(m1 + m2 + n1 * n2)/.
--
-- @
-- 'isEmpty'     (connect e x y) == 'isEmpty'   x   && 'isEmpty'   y
-- 'hasVertex' z (connect e x y) == 'hasVertex' z x || 'hasVertex' z y
-- 'vertexCount' (connect e x y) >= 'vertexCount' x
-- 'vertexCount' (connect e x y) <= 'vertexCount' x + 'vertexCount' y
-- 'edgeCount'   (connect e x y) <= 'vertexCount' x * 'vertexCount' y + 'edgeCount' x + 'edgeCount' y
-- 'vertexCount' (connect e 1 2) == 2
-- 'edgeCount'   (connect e 1 2) == if e == 'zero' then 0 else 1
-- @
connect :: (Eq e, Monoid e, Ord a) => e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
connect :: forall e a.
(Eq e, Monoid e, Ord a) =>
e -> AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
connect e
e (AM Map a (Map a e)
x) (AM Map a (Map a e)
y)
    | e
e forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = forall e a.
(Eq e, Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
overlay (forall e a. Map a (Map a e) -> AdjacencyMap e a
AM Map a (Map a e)
x) (forall e a. Map a (Map a e) -> AdjacencyMap e a
AM Map a (Map a e)
y)
    | Bool
otherwise   = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall e a.
(Eq e, Monoid e, Ord a) =>
Map a e -> Map a e -> Map a e
nonZeroUnion forall a b. (a -> b) -> a -> b
$ Map a (Map a e)
x forall a. a -> [a] -> [a]
: Map a (Map a e)
y forall a. a -> [a] -> [a]
:
        [ forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const Map a e
targets) (forall k a. Map k a -> Set k
Map.keysSet Map a (Map a e)
x) ]
  where
    targets :: Map a e
targets = forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const e
e) (forall k a. Map k a -> Set k
Map.keysSet Map a (Map a e)
y)

-- | Construct the graph comprising a given list of isolated vertices.
-- Complexity: /O(L * log(L))/ time and /O(L)/ memory, where /L/ is the length
-- of the given list.
--
-- @
-- vertices []            == 'empty'
-- vertices [x]           == 'vertex' x
-- vertices               == 'overlays' . map 'vertex'
-- 'hasVertex' x . vertices == 'elem' x
-- 'vertexCount' . vertices == 'length' . 'Data.List.nub'
-- 'vertexSet'   . vertices == Set.'Set.fromList'
-- @
vertices :: Ord a => [a] -> AdjacencyMap e a
vertices :: forall a e. Ord a => [a] -> AdjacencyMap e a
vertices = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (, forall k a. Map k a
Map.empty)

-- | Construct the graph from a list of edges.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- edges []        == 'empty'
-- edges [(e,x,y)] == 'edge' e x y
-- edges           == 'overlays' . 'map' (\\(e, x, y) -> 'edge' e x y)
-- @
edges :: (Eq e, Monoid e, Ord a) => [(e, a, a)] -> AdjacencyMap e a
edges :: forall e a.
(Eq e, Monoid e, Ord a) =>
[(e, a, a)] -> AdjacencyMap e a
edges [(e, a, a)]
es = forall e a.
(Eq e, Monoid e, Ord a) =>
[(a, Map a e)] -> AdjacencyMap e a
fromAdjacencyMaps [ (a
x, forall k a. k -> a -> Map k a
Map.singleton a
y e
e) | (e
e, a
x, a
y) <- [(e, a, a)]
es ]

-- | Overlay a given list of graphs.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- overlays []        == 'empty'
-- overlays [x]       == x
-- overlays [x,y]     == 'overlay' x y
-- overlays           == 'foldr' 'overlay' 'empty'
-- 'isEmpty' . overlays == 'all' 'isEmpty'
-- @
overlays :: (Eq e, Monoid e, Ord a) => [AdjacencyMap e a] -> AdjacencyMap e a
overlays :: forall e a.
(Eq e, Monoid e, Ord a) =>
[AdjacencyMap e a] -> AdjacencyMap e a
overlays = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall e a.
(Eq e, Monoid e, Ord a) =>
Map a e -> Map a e -> Map a e
nonZeroUnion forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | Construct a graph from a list of adjacency sets.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- fromAdjacencyMaps []                                  == 'empty'
-- fromAdjacencyMaps [(x, Map.'Map.empty')]                    == 'vertex' x
-- fromAdjacencyMaps [(x, Map.'Map.singleton' y e)]            == if e == 'zero' then 'vertices' [x,y] else 'edge' e x y
-- 'overlay' (fromAdjacencyMaps xs) (fromAdjacencyMaps ys) == fromAdjacencyMaps (xs '++' ys)
-- @
fromAdjacencyMaps :: (Eq e, Monoid e, Ord a) => [(a, Map a e)] -> AdjacencyMap e a
fromAdjacencyMaps :: forall e a.
(Eq e, Monoid e, Ord a) =>
[(a, Map a e)] -> AdjacencyMap e a
fromAdjacencyMaps [(a, Map a e)]
xs = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall a b. (a -> b) -> a -> b
$ forall e a. (Eq e, Monoid e) => Map a (Map a e) -> Map a (Map a e)
trimZeroes forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Monoid a => a -> a -> a
mappend Map a (Map a e)
vs Map a (Map a e)
es
  where
    vs :: Map a (Map a e)
vs = forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const forall k a. Map k a
Map.empty) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, Map a e)]
xs
    es :: Map a (Map a e)
es = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Monoid a => a -> a -> a
mappend) [(a, Map a e)]
xs

-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the
-- first graph is a /subgraph/ of the second.
-- Complexity: /O(s + m * log(m))/ time. Note that the number of edges /m/ of a
-- graph can be quadratic with respect to the expression size /s/.
--
-- @
-- isSubgraphOf 'empty'      x     ==  True
-- isSubgraphOf ('vertex' x) 'empty' ==  False
-- isSubgraphOf x y              ==> x <= y
-- @
isSubgraphOf :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a -> Bool
isSubgraphOf :: forall e a.
(Eq e, Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a -> Bool
isSubgraphOf (AM Map a (Map a e)
x) (AM Map a (Map a e)
y) = forall k a b.
Ord k =>
(a -> b -> Bool) -> Map k a -> Map k b -> Bool
Map.isSubmapOfBy (forall k a b.
Ord k =>
(a -> b -> Bool) -> Map k a -> Map k b -> Bool
Map.isSubmapOfBy forall {a}. (Eq a, Monoid a) => a -> a -> Bool
le) Map a (Map a e)
x Map a (Map a e)
y
  where
    le :: a -> a -> Bool
le a
x a
y = forall a. Monoid a => a -> a -> a
mappend a
x a
y forall a. Eq a => a -> a -> Bool
== a
y

-- | Check if a graph is empty.
-- Complexity: /O(1)/ time.
--
-- @
-- isEmpty 'empty'                         == True
-- isEmpty ('overlay' 'empty' 'empty')         == True
-- isEmpty ('vertex' x)                    == False
-- isEmpty ('removeVertex' x $ 'vertex' x)   == True
-- isEmpty ('removeEdge' x y $ 'edge' e x y) == False
-- @
isEmpty :: AdjacencyMap e a -> Bool
isEmpty :: forall e a. AdjacencyMap e a -> Bool
isEmpty = forall k a. Map k a -> Bool
Map.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | Check if a graph contains a given vertex.
-- Complexity: /O(log(n))/ time.
--
-- @
-- hasVertex x 'empty'            == False
-- hasVertex x ('vertex' y)       == (x == y)
-- hasVertex x . 'removeVertex' x == 'const' False
-- @
hasVertex :: Ord a => a -> AdjacencyMap e a -> Bool
hasVertex :: forall a e. Ord a => a -> AdjacencyMap e a -> Bool
hasVertex a
x = forall k a. Ord k => k -> Map k a -> Bool
Map.member a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | Check if a graph contains a given edge.
-- Complexity: /O(log(n))/ time.
--
-- @
-- hasEdge x y 'empty'            == False
-- hasEdge x y ('vertex' z)       == False
-- hasEdge x y ('edge' e x y)     == (e /= 'zero')
-- hasEdge x y . 'removeEdge' x y == 'const' False
-- hasEdge x y                  == 'not' . 'null' . 'filter' (\\(_,ex,ey) -> ex == x && ey == y) . 'edgeList'
-- @
hasEdge :: Ord a => a -> a -> AdjacencyMap e a -> Bool
hasEdge :: forall a e. Ord a => a -> a -> AdjacencyMap e a -> Bool
hasEdge a
x a
y (AM Map a (Map a e)
m) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall k a. Ord k => k -> Map k a -> Bool
Map.member a
y) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a (Map a e)
m)

-- | Extract the label of a specified edge in a graph.
-- Complexity: /O(log(n))/ time.
--
-- @
-- edgeLabel x y 'empty'         == 'zero'
-- edgeLabel x y ('vertex' z)    == 'zero'
-- edgeLabel x y ('edge' e x y)  == e
-- edgeLabel s t ('overlay' x y) == edgeLabel s t x <+> edgeLabel s t y
-- @
edgeLabel :: (Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> e
edgeLabel :: forall e a. (Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> e
edgeLabel a
x a
y (AM Map a (Map a e)
m) = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
zero (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a (Map a e)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
y)

-- | The number of vertices in a graph.
-- Complexity: /O(1)/ time.
--
-- @
-- vertexCount 'empty'             ==  0
-- vertexCount ('vertex' x)        ==  1
-- vertexCount                   ==  'length' . 'vertexList'
-- vertexCount x \< vertexCount y ==> x \< y
-- @
vertexCount :: AdjacencyMap e a -> Int
vertexCount :: forall e a. AdjacencyMap e a -> Int
vertexCount = forall k a. Map k a -> Int
Map.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | The number of (non-'zero') edges in a graph.
-- Complexity: /O(n)/ time.
--
-- @
-- edgeCount 'empty'        == 0
-- edgeCount ('vertex' x)   == 0
-- edgeCount ('edge' e x y) == if e == 'zero' then 0 else 1
-- edgeCount              == 'length' . 'edgeList'
-- @
edgeCount :: AdjacencyMap e a -> Int
edgeCount :: forall e a. AdjacencyMap e a -> Int
edgeCount = forall a. Sum a -> a
getSum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> Sum a
Sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> Int
Map.size) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | The sorted list of vertices of a given graph.
-- Complexity: /O(n)/ time and memory.
--
-- @
-- vertexList 'empty'      == []
-- vertexList ('vertex' x) == [x]
-- vertexList . 'vertices' == 'Data.List.nub' . 'Data.List.sort'
-- @
vertexList :: AdjacencyMap e a -> [a]
vertexList :: forall e a. AdjacencyMap e a -> [a]
vertexList = forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | The list of edges of a graph, sorted lexicographically with respect to
-- pairs of connected vertices (i.e. edge-labels are ignored when sorting).
-- Complexity: /O(n + m)/ time and /O(m)/ memory.
--
-- @
-- edgeList 'empty'        == []
-- edgeList ('vertex' x)   == []
-- edgeList ('edge' e x y) == if e == 'zero' then [] else [(e,x,y)]
-- @
edgeList :: AdjacencyMap e a -> [(e, a, a)]
edgeList :: forall e a. AdjacencyMap e a -> [(e, a, a)]
edgeList (AM Map a (Map a e)
m) =
    [ (e
e, a
x, a
y) | (a
x, Map a e
ys) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Map a e)
m, (a
y, e
e) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map a e
ys ]

-- | The set of vertices of a given graph.
-- Complexity: /O(n)/ time and memory.
--
-- @
-- vertexSet 'empty'      == Set.'Set.empty'
-- vertexSet . 'vertex'   == Set.'Set.singleton'
-- vertexSet . 'vertices' == Set.'Set.fromList'
-- @
vertexSet :: AdjacencyMap e a -> Set a
vertexSet :: forall e a. AdjacencyMap e a -> Set a
vertexSet = forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | The set of edges of a given graph.
-- Complexity: /O(n + m)/ time and /O(m)/ memory.
--
-- @
-- edgeSet 'empty'        == Set.'Set.empty'
-- edgeSet ('vertex' x)   == Set.'Set.empty'
-- edgeSet ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.singleton' (e,x,y)
-- @
edgeSet :: (Eq a, Eq e) => AdjacencyMap e a -> Set (e, a, a)
edgeSet :: forall a e. (Eq a, Eq e) => AdjacencyMap e a -> Set (e, a, a)
edgeSet = forall a. Eq a => [a] -> Set a
Set.fromAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> [(e, a, a)]
edgeList

-- | The /preset/ of an element @x@ is the set of its /direct predecessors/.
-- Complexity: /O(n * log(n))/ time and /O(n)/ memory.
--
-- @
-- preSet x 'empty'        == Set.'Set.empty'
-- preSet x ('vertex' x)   == Set.'Set.empty'
-- preSet 1 ('edge' e 1 2) == Set.'Set.empty'
-- preSet y ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.fromList' [x]
-- @
preSet :: Ord a => a -> AdjacencyMap e a -> Set a
preSet :: forall a e. Ord a => a -> AdjacencyMap e a -> Set a
preSet a
x (AM Map a (Map a e)
m) = forall a. Eq a => [a] -> Set a
Set.fromAscList
    [ a
a | (a
a, Map a e
es) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Map a e)
m, forall k a. Ord k => k -> Map k a -> Bool
Map.member a
x Map a e
es ]

-- | The /postset/ of a vertex is the set of its /direct successors/.
-- Complexity: /O(log(n))/ time and /O(1)/ memory.
--
-- @
-- postSet x 'empty'        == Set.'Set.empty'
-- postSet x ('vertex' x)   == Set.'Set.empty'
-- postSet x ('edge' e x y) == if e == 'zero' then Set.'Set.empty' else Set.'Set.fromList' [y]
-- postSet 2 ('edge' e 1 2) == Set.'Set.empty'
-- @
postSet :: Ord a => a -> AdjacencyMap e a -> Set a
postSet :: forall a e. Ord a => a -> AdjacencyMap e a -> Set a
postSet a
x = forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault forall k a. Map k a
Map.empty a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- TODO: Optimise.
-- | Convert a graph to the corresponding unlabelled 'AM.AdjacencyMap' by
-- forgetting labels on all non-'zero' edges.
-- Complexity: /O((n + m) * log(n))/ time and memory.
--
-- @
-- 'hasEdge' x y == 'AM.hasEdge' x y . skeleton
-- @
skeleton :: Ord a => AdjacencyMap e a -> AM.AdjacencyMap a
skeleton :: forall a e. Ord a => AdjacencyMap e a -> AdjacencyMap a
skeleton (AM Map a (Map a e)
m) = forall a. Ord a => [(a, Set a)] -> AdjacencyMap a
AM.fromAdjacencySets forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall k a. Map k a -> Set k
Map.keysSet Map a (Map a e)
m

-- | Remove a vertex from a given graph.
-- Complexity: /O(n*log(n))/ time.
--
-- @
-- removeVertex x ('vertex' x)       == 'empty'
-- removeVertex 1 ('vertex' 2)       == 'vertex' 2
-- removeVertex x ('edge' e x x)     == 'empty'
-- removeVertex 1 ('edge' e 1 2)     == 'vertex' 2
-- removeVertex x . removeVertex x == removeVertex x
-- @
removeVertex :: Ord a => a -> AdjacencyMap e a -> AdjacencyMap e a
removeVertex :: forall a e. Ord a => a -> AdjacencyMap e a -> AdjacencyMap e a
removeVertex a
x = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
x) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | Remove an edge from a given graph.
-- Complexity: /O(log(n))/ time.
--
-- @
-- removeEdge x y ('edge' e x y)     == 'vertices' [x,y]
-- removeEdge x y . removeEdge x y == removeEdge x y
-- removeEdge x y . 'removeVertex' x == 'removeVertex' x
-- removeEdge 1 1 (1 * 1 * 2 * 2)  == 1 * 2 * 2
-- removeEdge 1 2 (1 * 1 * 2 * 2)  == 1 * 1 + 2 * 2
-- @
removeEdge :: Ord a => a -> a -> AdjacencyMap e a -> AdjacencyMap e a
removeEdge :: forall a e. Ord a => a -> a -> AdjacencyMap e a -> AdjacencyMap e a
removeEdge a
x a
y = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
y) a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | The function @'replaceVertex' x y@ replaces vertex @x@ with vertex @y@ in a
-- given 'AdjacencyMap'. If @y@ already exists, @x@ and @y@ will be merged.
-- Complexity: /O((n + m) * log(n))/ time.
--
-- @
-- replaceVertex x x            == id
-- replaceVertex x y ('vertex' x) == 'vertex' y
-- replaceVertex x y            == 'gmap' (\\v -> if v == x then y else v)
-- @
replaceVertex :: (Eq e, Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> AdjacencyMap e a
replaceVertex :: forall e a.
(Eq e, Monoid e, Ord a) =>
a -> a -> AdjacencyMap e a -> AdjacencyMap e a
replaceVertex a
u a
v = forall e a b.
(Eq e, Monoid e, Ord a, Ord b) =>
(a -> b) -> AdjacencyMap e a -> AdjacencyMap e b
gmap forall a b. (a -> b) -> a -> b
$ \a
w -> if a
w forall a. Eq a => a -> a -> Bool
== a
u then a
v else a
w

-- | Replace an edge from a given graph. If it doesn't exist, it will be created.
-- Complexity: /O(log(n))/ time.
--
-- @
-- replaceEdge e x y z                 == 'overlay' (removeEdge x y z) ('edge' e x y)
-- replaceEdge e x y ('edge' f x y)      == 'edge' e x y
-- 'edgeLabel' x y (replaceEdge e x y z) == e
-- @
replaceEdge :: (Eq e, Monoid e, Ord a) => e -> a -> a -> AdjacencyMap e a -> AdjacencyMap e a
replaceEdge :: forall e a.
(Eq e, Monoid e, Ord a) =>
e -> a -> a -> AdjacencyMap e a -> AdjacencyMap e a
replaceEdge e
e a
x a
y
    | e
e forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
zero  = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a (Map a e) -> Map a (Map a e)
addY forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall k a. Map k a
Map.empty (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
y)) a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap
    | Bool
otherwise  = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a (Map a e) -> Map a (Map a e)
addY forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Map a e) -> Maybe (Map a e)
replace a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap
  where
    addY :: Map a (Map a e) -> Map a (Map a e)
addY             = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
Map.empty) a
y
    replace :: Maybe (Map a e) -> Maybe (Map a e)
replace (Just Map a e
m) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert a
y e
e Map a e
m
    replace Maybe (Map a e)
Nothing  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a. k -> a -> Map k a
Map.singleton a
y e
e

-- | Transpose a given graph.
-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory.
--
-- @
-- transpose 'empty'        == 'empty'
-- transpose ('vertex' x)   == 'vertex' x
-- transpose ('edge' e x y) == 'edge' e y x
-- transpose . transpose  == id
-- @
transpose :: (Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a
transpose :: forall e a.
(Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a
transpose (AM Map a (Map a e)
m) = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall a b. (a -> b) -> a -> b
$ forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey forall {k} {k} {a}.
(Ord k, Ord k, Monoid a) =>
k -> Map k a -> Map k (Map k a) -> Map k (Map k a)
combine Map a (Map a e)
vs Map a (Map a e)
m
  where
    -- No need to use @nonZeroUnion@ here, since we do not add any new edges
    combine :: k -> Map k a -> Map k (Map k a) -> Map k (Map k a)
combine k
v Map k a
es = forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Monoid a => a -> a -> a
mappend) forall a b. (a -> b) -> a -> b
$
        forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [ (k
u, forall k a. k -> a -> Map k a
Map.singleton k
v a
e) | (k
u, a
e) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map k a
es ]
    vs :: Map a (Map a e)
vs = forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (forall a b. a -> b -> a
const forall k a. Map k a
Map.empty) (forall k a. Map k a -> Set k
Map.keysSet Map a (Map a e)
m)

-- | Transform a graph by applying a function to each of its vertices. This is
-- similar to @Functor@'s 'fmap' but can be used with non-fully-parametric
-- 'AdjacencyMap'.
-- Complexity: /O((n + m) * log(n))/ time.
--
-- @
-- gmap f 'empty'        == 'empty'
-- gmap f ('vertex' x)   == 'vertex' (f x)
-- gmap f ('edge' e x y) == 'edge' e (f x) (f y)
-- gmap 'id'             == 'id'
-- gmap f . gmap g     == gmap (f . g)
-- @
gmap :: (Eq e, Monoid e, Ord a, Ord b) => (a -> b) -> AdjacencyMap e a -> AdjacencyMap e b
gmap :: forall e a b.
(Eq e, Monoid e, Ord a, Ord b) =>
(a -> b) -> AdjacencyMap e a -> AdjacencyMap e b
gmap a -> b
f = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. (Eq e, Monoid e) => Map a (Map a e) -> Map a (Map a e)
trimZeroes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith forall a. Monoid a => a -> a -> a
mappend a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Monoid a => a -> a -> a
mappend) a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | Transform a graph by applying a function @h@ to each of its edge labels.
-- Complexity: /O((n + m) * log(n))/ time.
--
-- The function @h@ is required to be a /homomorphism/ on the underlying type of
-- labels @e@. At the very least it must preserve 'zero' and '<+>':
--
-- @
-- h 'zero'      == 'zero'
-- h x '<+>' h y == h (x '<+>' y)
-- @
--
-- If @e@ is also a semiring, then @h@ must also preserve the multiplicative
-- structure:
--
-- @
-- h 'one'       == 'one'
-- h x '<.>' h y == h (x '<.>' y)
-- @
--
-- If the above requirements hold, then the implementation provides the
-- following guarantees.
--
-- @
-- emap h 'empty'           == 'empty'
-- emap h ('vertex' x)      == 'vertex' x
-- emap h ('edge' e x y)    == 'edge' (h e) x y
-- emap h ('overlay' x y)   == 'overlay' (emap h x) (emap h y)
-- emap h ('connect' e x y) == 'connect' (h e) (emap h x) (emap h y)
-- emap 'id'                == 'id'
-- emap g . emap h        == emap (g . h)
-- @
emap :: (Eq f, Monoid f) => (e -> f) -> AdjacencyMap e a -> AdjacencyMap f a
emap :: forall f e a.
(Eq f, Monoid f) =>
(e -> f) -> AdjacencyMap e a -> AdjacencyMap f a
emap e -> f
h = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. (Eq e, Monoid e) => Map a (Map a e) -> Map a (Map a e)
trimZeroes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map e -> f
h) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | Construct the /induced subgraph/ of a given graph by removing the
-- vertices that do not satisfy a given predicate.
-- Complexity: /O(n + m)/ time, assuming that the predicate takes constant time.
--
-- @
-- induce ('const' True ) x      == x
-- induce ('const' False) x      == 'empty'
-- induce (/= x)               == 'removeVertex' x
-- induce p . induce q         == induce (\\x -> p x && q x)
-- 'isSubgraphOf' (induce p x) x == True
-- @
induce :: (a -> Bool) -> AdjacencyMap e a -> AdjacencyMap e a
induce :: forall a e. (a -> Bool) -> AdjacencyMap e a -> AdjacencyMap e a
induce a -> Bool
p = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\a
k e
_ -> a -> Bool
p a
k)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\a
k Map a e
_ -> a -> Bool
p a
k) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap

-- | Construct the /induced subgraph/ of a given graph by removing the vertices
-- that are 'Nothing'.
-- Complexity: /O(n + m)/ time.
--
-- @
-- induceJust ('vertex' 'Nothing')                               == 'empty'
-- induceJust ('edge' ('Just' x) 'Nothing')                        == 'vertex' x
-- induceJust . 'gmap' 'Just'                                    == 'id'
-- induceJust . 'gmap' (\\x -> if p x then 'Just' x else 'Nothing') == 'induce' p
-- @
induceJust :: Ord a => AdjacencyMap e (Maybe a) -> AdjacencyMap e a
induceJust :: forall a e. Ord a => AdjacencyMap e (Maybe a) -> AdjacencyMap e a
induceJust = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall {a}. Map (Maybe a) a -> Map a a
catMaybesMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Map (Maybe a) a -> Map a a
catMaybesMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. AdjacencyMap e a -> Map a (Map a e)
adjacencyMap
  where
    catMaybesMap :: Map (Maybe a) a -> Map a a
catMaybesMap = forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Map k a
Map.delete forall a. Maybe a
Nothing

-- | Compute the /reflexive and transitive closure/ of a graph over the
-- underlying star semiring using the Warshall-Floyd-Kleene algorithm.
--
-- @
-- closure 'empty'         == 'empty'
-- closure ('vertex' x)    == 'edge' 'one' x x
-- closure ('edge' e x x)  == 'edge' 'one' x x
-- closure ('edge' e x y)  == 'edges' [('one',x,x), (e,x,y), ('one',y,y)]
-- closure               == 'reflexiveClosure' . 'transitiveClosure'
-- closure               == 'transitiveClosure' . 'reflexiveClosure'
-- closure . closure     == closure
-- 'postSet' x (closure y) == Set.'Set.fromList' ('Algebra.Graph.ToGraph.reachable' y x)
-- @
closure :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a
closure :: forall e a.
(Eq e, Ord a, StarSemiring e) =>
AdjacencyMap e a -> AdjacencyMap e a
closure = forall e a.
(Eq e, Ord a, StarSemiring e) =>
AdjacencyMap e a -> AdjacencyMap e a
goWarshallFloydKleene forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a e.
(Ord a, Semiring e) =>
AdjacencyMap e a -> AdjacencyMap e a
reflexiveClosure

-- | Compute the /reflexive closure/ of a graph over the underlying semiring by
-- adding a self-loop of weight 'one' to every vertex.
-- Complexity: /O(n * log(n))/ time.
--
-- @
-- reflexiveClosure 'empty'              == 'empty'
-- reflexiveClosure ('vertex' x)         == 'edge' 'one' x x
-- reflexiveClosure ('edge' e x x)       == 'edge' 'one' x x
-- reflexiveClosure ('edge' e x y)       == 'edges' [('one',x,x), (e,x,y), ('one',y,y)]
-- reflexiveClosure . reflexiveClosure == reflexiveClosure
-- @
reflexiveClosure :: (Ord a, Semiring e) => AdjacencyMap e a -> AdjacencyMap e a
reflexiveClosure :: forall a e.
(Ord a, Semiring e) =>
AdjacencyMap e a -> AdjacencyMap e a
reflexiveClosure (AM Map a (Map a e)
m) = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall a b. (a -> b) -> a -> b
$ forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\a
k -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith forall a. Semigroup a => a -> a -> a
(<+>) a
k forall a. Semiring a => a
one) Map a (Map a e)
m

-- | Compute the /symmetric closure/ of a graph by overlaying it with its own
-- transpose.
-- Complexity: /O((n + m) * log(n))/ time.
--
-- @
-- symmetricClosure 'empty'              == 'empty'
-- symmetricClosure ('vertex' x)         == 'vertex' x
-- symmetricClosure ('edge' e x y)       == 'edges' [(e,x,y), (e,y,x)]
-- symmetricClosure x                  == 'overlay' x ('transpose' x)
-- symmetricClosure . symmetricClosure == symmetricClosure
-- @
symmetricClosure :: (Eq e, Monoid e, Ord a) => AdjacencyMap e a -> AdjacencyMap e a
symmetricClosure :: forall e a.
(Eq e, Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a
symmetricClosure AdjacencyMap e a
m = forall e a.
(Eq e, Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a -> AdjacencyMap e a
overlay AdjacencyMap e a
m (forall e a.
(Monoid e, Ord a) =>
AdjacencyMap e a -> AdjacencyMap e a
transpose AdjacencyMap e a
m)

-- | Compute the /transitive closure/ of a graph over the underlying star
-- semiring using a modified version of the Warshall-Floyd-Kleene algorithm,
-- which omits the reflexivity step.
--
-- @
-- transitiveClosure 'empty'               == 'empty'
-- transitiveClosure ('vertex' x)          == 'vertex' x
-- transitiveClosure ('edge' e x y)        == 'edge' e x y
-- transitiveClosure . transitiveClosure == transitiveClosure
-- @
transitiveClosure :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a
transitiveClosure :: forall e a.
(Eq e, Ord a, StarSemiring e) =>
AdjacencyMap e a -> AdjacencyMap e a
transitiveClosure = forall e a.
(Eq e, Ord a, StarSemiring e) =>
AdjacencyMap e a -> AdjacencyMap e a
goWarshallFloydKleene

-- The iterative part of the Warshall-Floyd-Kleene algorithm
goWarshallFloydKleene :: (Eq e, Ord a, StarSemiring e) => AdjacencyMap e a -> AdjacencyMap e a
goWarshallFloydKleene :: forall e a.
(Eq e, Ord a, StarSemiring e) =>
AdjacencyMap e a -> AdjacencyMap e a
goWarshallFloydKleene (AM Map a (Map a e)
m) = forall e a. Map a (Map a e) -> AdjacencyMap e a
AM forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> Map a (Map a e) -> Map a (Map a e)
update Map a (Map a e)
m [a]
vs
  where
    vs :: [a]
vs = forall a. Set a -> [a]
Set.toAscList (forall k a. Map k a -> Set k
Map.keysSet Map a (Map a e)
m)
    update :: a -> Map a (Map a e) -> Map a (Map a e)
update a
k Map a (Map a e)
cur = forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [ (a
i, a -> e -> Map a e
go a
i (a -> a -> e
get a
i a
k forall a. Semiring a => a -> a -> a
<.> e
starkk)) | a
i <- [a]
vs ]
      where
        get :: a -> a -> e
get a
i a
j = forall e a. (Monoid e, Ord a) => a -> a -> AdjacencyMap e a -> e
edgeLabel a
i a
j (forall e a. Map a (Map a e) -> AdjacencyMap e a
AM Map a (Map a e)
cur)
        starkk :: e
starkk  = forall a. StarSemiring a => a -> a
star (a -> a -> e
get a
k a
k)
        go :: a -> e -> Map a e
go a
i e
ik = forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
            [ (a
j, e
e) | a
j <- [a]
vs, let e :: e
e = a -> a -> e
get a
i a
j forall a. Semigroup a => a -> a -> a
<+> e
ik forall a. Semiring a => a -> a -> a
<.> a -> a -> e
get a
k a
j, e
e forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
zero ]

-- | Check that the internal graph representation is consistent, i.e. that all
-- edges refer to existing vertices, and there are no 'zero'-labelled edges. It
-- should be impossible to create an inconsistent adjacency map, and we use this
-- function in testing.
consistent :: (Ord a, Eq e, Monoid e) => AdjacencyMap e a -> Bool
consistent :: forall a e. (Ord a, Eq e, Monoid e) => AdjacencyMap e a -> Bool
consistent (AM Map a (Map a e)
m) = forall a e. Ord a => Map a (Map a e) -> Set a
referredToVertexSet Map a (Map a e)
m forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` forall k a. Map k a -> Set k
Map.keysSet Map a (Map a e)
m
    Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ e
e forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
zero | (a
_, Map a e
es) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Map a e)
m, (a
_, e
e) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map a e
es ]

-- The set of vertices that are referred to by the edges in an adjacency map
referredToVertexSet :: Ord a => Map a (Map a e) -> Set a
referredToVertexSet :: forall a e. Ord a => Map a (Map a e) -> Set a
referredToVertexSet Map a (Map a e)
m = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [a
x, a
y] | (a
x, Map a e
ys) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map a (Map a e)
m, (a
y, e
_) <- forall k a. Map k a -> [(k, a)]
Map.toAscList Map a e
ys ]