-----------------------------------------------------------------------------
-- |
-- Module     : Algebra.Graph.Acyclic.AdjacencyMap
-- Copyright  : (c) Andrey Mokhov 2016-2022
-- License    : MIT (see the file LICENSE)
-- Maintainer : andrey.mokhov@gmail.com
-- 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 and for acyclic graphs, as
-- well as associated operations and algorithms. To avoid name clashes with
-- "Algebra.Graph.AdjacencyMap", this module can be imported qualified:
--
-- @
-- import qualified Algebra.Graph.Acyclic.AdjacencyMap as Acyclic
-- @
-----------------------------------------------------------------------------
module Algebra.Graph.Acyclic.AdjacencyMap (
    -- * Data structure
    AdjacencyMap, fromAcyclic,

    -- * Basic graph construction primitives
    empty, vertex, vertices, union, join,

    -- * Relations on graphs
    isSubgraphOf,

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

    -- * Graph transformation
    removeVertex, removeEdge, transpose, induce, induceJust,

    -- * Graph composition
    box,

    -- * Relational operations
    transitiveClosure,

    -- * Algorithms
    topSort, scc,

    -- * Conversion to acyclic graphs
    toAcyclic, toAcyclicOrd, shrink,

    -- * Miscellaneous
    consistent
    ) where

import Data.Set (Set)
import Data.Coerce (coerce)

import qualified Algebra.Graph.AdjacencyMap           as AM
import qualified Algebra.Graph.AdjacencyMap.Algorithm as AM
import qualified Algebra.Graph.NonEmpty.AdjacencyMap  as NAM
import qualified Data.List.NonEmpty                   as NonEmpty
import qualified Data.Map                             as Map
import qualified Data.Set                             as Set

{-| The 'AdjacencyMap' data type represents an acyclic graph by a map of
vertices to their adjacency sets. Although the internal representation allows
for cycles, the methods provided by this module cannot be used to construct a
graph with cycles.

The 'Show' instance is defined using basic graph construction primitives where
possible, falling back to 'toAcyclic' and "Algebra.Graph.AdjacencyMap"
otherwise:

@
show empty                == "empty"
show (shrink 1)           == "vertex 1"
show (shrink $ 1 + 2)     == "vertices [1,2]"
show (shrink $ 1 * 2)     == "(fromJust . toAcyclic) (edge 1 2)"
show (shrink $ 1 * 2 * 3) == "(fromJust . toAcyclic) (edges [(1,2),(1,3),(2,3)])"
show (shrink $ 1 * 2 + 3) == "(fromJust . toAcyclic) (overlay (vertex 3) (edge 1 2))"
@

The total order on graphs is defined using /size-lexicographic/ comparison:

* Compare the number of vertices. In case of a tie, continue.
* Compare the sets of vertices. In case of a tie, continue.
* Compare the number of edges. In case of a tie, continue.
* Compare the sets of edges.

Note that the resulting order refines the 'isSubgraphOf' relation:

@'isSubgraphOf' x y ==> x <= y@
-}

-- TODO: Improve the Show instance.
newtype AdjacencyMap a = AAM {
    -- | Extract the underlying acyclic "Algebra.Graph.AdjacencyMap".
    -- Complexity: /O(1)/ time and memory.
    --
    -- @
    -- fromAcyclic 'empty'                == 'AM.empty'
    -- fromAcyclic . 'vertex'             == 'AM.vertex'
    -- fromAcyclic (shrink $ 1 * 3 + 2) == 1 * 3 + 2
    -- 'AM.vertexCount' . fromAcyclic        == 'vertexCount'
    -- 'AM.edgeCount'   . fromAcyclic        == 'edgeCount'
    -- 'AM.isAcyclic'   . fromAcyclic        == 'const' True
    -- @
    fromAcyclic :: AM.AdjacencyMap a
    } deriving (Eq, Ord)

instance (Ord a, Show a) => Show (AdjacencyMap a) where
    showsPrec p aam@(AAM am)
        | null vs    = showString "empty"
        | null es    = showParen (p > 10) $ vshow vs
        | otherwise  = showParen (p > 10) $ showString "(fromJust . toAcyclic) ("
                     . shows am . showString ")"
      where
        vs             = vertexList aam
        es             = edgeList aam
        vshow [x]      = showString "vertex "   . showsPrec 11 x
        vshow xs       = showString "vertices " . showsPrec 11 xs

-- | Construct the /empty graph/.
--
-- @
-- 'isEmpty'     empty == True
-- 'hasVertex' x empty == False
-- 'vertexCount' empty == 0
-- 'edgeCount'   empty == 0
-- @
empty :: AdjacencyMap a
empty = coerce AM.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 a
vertex = coerce AM.vertex

-- | 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
-- 'hasVertex' x . vertices == 'elem' x
-- 'vertexCount' . vertices == 'length' . 'Data.List.nub'
-- 'vertexSet'   . vertices == Set.'Set.fromList'
-- @
vertices :: Ord a => [a] -> AdjacencyMap a
vertices = coerce AM.vertices

-- | Construct the disjoint /union/ of two graphs.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- 'vertexSet' (union x y) == Set.'Set.unions' [ Set.'Set.map' 'Left'  ('vertexSet' x)
--                                     , Set.'Set.map' 'Right' ('vertexSet' y) ]
--
-- 'edgeSet'   (union x y) == Set.'Set.unions' [ Set.'Set.map' ('Data.Bifunctor.bimap' 'Left'  'Left' ) ('edgeSet' x)
--                                     , Set.'Set.map' ('Data.Bifunctor.bimap' 'Right' 'Right') ('edgeSet' y) ]
-- @
union :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (Either a b)
union (AAM x) (AAM y) = AAM $ AM.overlay (AM.gmap Left x) (AM.gmap Right y)

-- | Construct the /join/ of two graphs.
-- Complexity: /O((n + m) * log(n))/ time and /O(n + m)/ memory.
--
-- @
-- 'vertexSet' (join x y) == Set.'Set.unions' [ Set.'Set.map' 'Left'  ('vertexSet' x)
--                                    , Set.'Set.map' 'Right' ('vertexSet' y) ]
--
-- 'edgeSet'   (join x y) == Set.'Set.unions' [ Set.'Set.map' ('Data.Bifunctor.bimap' 'Left'  'Left' ) ('edgeSet' x)
--                                    , Set.'Set.map' ('Data.Bifunctor.bimap' 'Right' 'Right') ('edgeSet' y)
--                                    , Set.'Set.map' ('Data.Bifunctor.bimap' 'Left'  'Right') (Set.'Set.cartesianProduct' ('vertexSet' x) ('vertexSet' y)) ]
-- @
join :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (Either a b)
join (AAM a) (AAM b) = AAM $ AM.connect (AM.gmap Left a) (AM.gmap Right b)

-- | The 'isSubgraphOf' function takes two graphs and returns 'True' if the
-- first graph is a /subgraph/ of the second.
-- Complexity: /O((n + m) * log(n))/ time.
--
-- @
-- isSubgraphOf 'empty'        x                     ==  True
-- isSubgraphOf ('vertex' x)   'empty'                 ==  False
-- isSubgraphOf ('induce' p x) x                     ==  True
-- isSubgraphOf x            ('transitiveClosure' x) ==  True
-- isSubgraphOf x y                                ==> x <= y
-- @
isSubgraphOf :: Ord a => AdjacencyMap a -> AdjacencyMap a -> Bool
isSubgraphOf = coerce AM.isSubgraphOf

-- | Check if a graph is empty.
-- Complexity: /O(1)/ time.
--
-- @
-- isEmpty 'empty'                             == True
-- isEmpty ('vertex' x)                        == False
-- isEmpty ('removeVertex' x $ 'vertex' x)       == True
-- isEmpty ('removeEdge' 1 2 $ shrink $ 1 * 2) == False
-- @
isEmpty :: AdjacencyMap a -> Bool
isEmpty = coerce AM.isEmpty

-- | 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 a -> Bool
hasVertex = coerce AM.hasVertex

-- | 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 1 2 (shrink $ 1 * 2) == True
-- hasEdge x y . 'removeEdge' x y == 'const' False
-- hasEdge x y                  == 'elem' (x,y) . 'edgeList'
-- @
hasEdge :: Ord a => a -> a -> AdjacencyMap a -> Bool
hasEdge = coerce AM.hasEdge

-- | 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 a -> Int
vertexCount = coerce AM.vertexCount

-- | The number of edges in a graph.
-- Complexity: /O(n)/ time.
--
-- @
-- edgeCount 'empty'            == 0
-- edgeCount ('vertex' x)       == 0
-- edgeCount (shrink $ 1 * 2) == 1
-- edgeCount                  == 'length' . 'edgeList'
-- @
edgeCount :: AdjacencyMap a -> Int
edgeCount = coerce AM.edgeCount

-- | 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 a -> [a]
vertexList = coerce AM.vertexList

-- | The sorted list of edges of a graph.
-- Complexity: /O(n + m)/ time and /O(m)/ memory.
--
-- @
-- edgeList 'empty'            == []
-- edgeList ('vertex' x)       == []
-- edgeList (shrink $ 2 * 1) == [(2,1)]
-- edgeList . 'transpose'      == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . edgeList
-- @
edgeList :: AdjacencyMap a -> [(a, a)]
edgeList = coerce AM.edgeList

-- | The sorted /adjacency list/ of a graph.
-- Complexity: /O(n + m)/ time and memory.
--
-- @
-- adjacencyList 'empty'            == []
-- adjacencyList ('vertex' x)       == [(x, [])]
-- adjacencyList (shrink $ 1 * 2) == [(1, [2]), (2, [])]
-- @
adjacencyList :: AdjacencyMap a -> [(a, [a])]
adjacencyList = coerce AM.adjacencyList

-- | 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 a -> Set a
vertexSet = coerce AM.vertexSet

-- | The set of edges of a given graph.
-- Complexity: /O((n + m) * log(m))/ time and /O(m)/ memory.
--
-- @
-- edgeSet 'empty'            == Set.'Set.empty'
-- edgeSet ('vertex' x)       == Set.'Set.empty'
-- edgeSet (shrink $ 1 * 2) == Set.'Set.singleton' (1,2)
-- @
edgeSet :: Eq a => AdjacencyMap a -> Set (a, a)
edgeSet = coerce AM.edgeSet

-- | 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 (shrink $ 1 * 2) == Set.'Set.empty'
-- preSet 2 (shrink $ 1 * 2) == Set.'Set.fromList' [1]
-- Set.'Set.member' x . preSet x   == 'const' False
-- @
preSet :: Ord a => a -> AdjacencyMap a -> Set a
preSet = coerce AM.preSet

-- | 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 1 (shrink $ 1 * 2) == Set.'Set.fromList' [2]
-- postSet 2 (shrink $ 1 * 2) == Set.'Set.empty'
-- Set.'Set.member' x . postSet x   == 'const' False
-- @
postSet :: Ord a => a -> AdjacencyMap a -> Set a
postSet = coerce AM.postSet

-- | Remove a vertex from a given acyclic graph.
-- Complexity: /O(n*log(n))/ time.
--
-- @
-- removeVertex x ('vertex' x)       == 'empty'
-- removeVertex 1 ('vertex' 2)       == 'vertex' 2
-- removeVertex 1 (shrink $ 1 * 2) == 'vertex' 2
-- removeVertex x . removeVertex x == removeVertex x
-- @
removeVertex :: Ord a => a -> AdjacencyMap a -> AdjacencyMap a
removeVertex = coerce AM.removeVertex

-- | Remove an edge from a given acyclic graph.
-- Complexity: /O(log(n))/ time.
--
-- @
-- removeEdge 1 2 (shrink $ 1 * 2)     == 'vertices' [1,2]
-- removeEdge x y . removeEdge x y     == removeEdge x y
-- removeEdge x y . 'removeVertex' x     == 'removeVertex' x
-- removeEdge 1 2 (shrink $ 1 * 2 * 3) == shrink ((1 + 2) * 3)
-- @
removeEdge :: Ord a => a -> a -> AdjacencyMap a -> AdjacencyMap a
removeEdge = coerce AM.removeEdge

-- | Transpose a given acyclic graph.
-- Complexity: /O(m * log(n))/ time, /O(n + m)/ memory.
--
-- @
-- transpose 'empty'       == 'empty'
-- transpose ('vertex' x)  == 'vertex' x
-- transpose . transpose == id
-- 'edgeList' . transpose  == 'Data.List.sort' . 'map' 'Data.Tuple.swap' . 'edgeList'
-- @
transpose :: Ord a => AdjacencyMap a -> AdjacencyMap a
transpose = coerce AM.transpose

-- | 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 a -> AdjacencyMap a
induce = coerce AM.induce

-- | 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 . 'vertex' . 'Just'  == 'vertex'
-- @
induceJust :: Ord a => AdjacencyMap (Maybe a) -> AdjacencyMap a
induceJust = coerce AM.induceJust

-- | Compute the /Cartesian product/ of graphs.
-- Complexity: /O((n + m) * log(n))/ time and O(n + m) memory.
--
-- @
-- 'edgeList' (box ('shrink' $ 1 * 2) ('shrink' $ 10 * 20)) == [ ((1,10), (1,20))
--                                                       , ((1,10), (2,10))
--                                                       , ((1,20), (2,20))
--                                                       , ((2,10), (2,20)) ]
-- @
--
-- Up to isomorphism between the resulting vertex types, this operation is
-- /commutative/ and /associative/, has singleton graphs as /identities/ and
-- 'empty' as the /annihilating zero/. Below @~~@ stands for equality up to
-- an isomorphism, e.g. @(x,@ @()) ~~ x@.
--
-- @
-- box x y               ~~ box y x
-- box x (box y z)       ~~ box (box x y) z
-- box x ('vertex' ())     ~~ x
-- box x 'empty'           ~~ 'empty'
-- 'transpose'   (box x y) == box ('transpose' x) ('transpose' y)
-- 'vertexCount' (box x y) == 'vertexCount' x * 'vertexCount' y
-- 'edgeCount'   (box x y) <= 'vertexCount' x * 'edgeCount' y + 'edgeCount' x * 'vertexCount' y
-- @
box :: (Ord a, Ord b) => AdjacencyMap a -> AdjacencyMap b -> AdjacencyMap (a, b)
box = coerce AM.box

-- | Compute the /transitive closure/ of a graph.
-- Complexity: /O(n * m * log(n)^2)/ time.
--
-- @
-- transitiveClosure 'empty'                    == 'empty'
-- transitiveClosure ('vertex' x)               == 'vertex' x
-- transitiveClosure (shrink $ 1 * 2 + 2 * 3) == shrink (1 * 2 + 1 * 3 + 2 * 3)
-- transitiveClosure . transitiveClosure      == transitiveClosure
-- @
transitiveClosure :: Ord a => AdjacencyMap a -> AdjacencyMap a
transitiveClosure = coerce AM.transitiveClosure

-- | Compute a /topological sort/ of an acyclic graph.
--
-- @
-- topSort 'empty'                          == []
-- topSort ('vertex' x)                     == [x]
-- topSort (shrink $ 1 * (2 + 4) + 3 * 4) == [1, 2, 3, 4]
-- topSort ('join' x y)                     == 'fmap' 'Left' (topSort x) ++ 'fmap' 'Right' (topSort y)
-- 'Right' . topSort                        == 'AM.topSort' . 'fromAcyclic'
-- @
topSort :: Ord a => AdjacencyMap a -> [a]
topSort g = case AM.topSort (coerce g) of
    Right vs -> vs
    Left _ -> error "Internal error: the acyclicity invariant is violated in topSort"

-- | Compute the acyclic /condensation/ of a graph, where each vertex
-- corresponds to a /strongly-connected component/ of the original graph. Note
-- that component graphs are non-empty, and are therefore of type
-- "Algebra.Graph.NonEmpty.AdjacencyMap".
--
-- @
--            scc 'AM.empty'               == 'empty'
--            scc ('AM.vertex' x)          == 'vertex' (NonEmpty.'NonEmpty.vertex' x)
--            scc ('AM.edge' 1 1)          == 'vertex' (NonEmpty.'NonEmpty.edge' 1 1)
-- 'edgeList' $ scc ('AM.edge' 1 2)          == [ (NonEmpty.'NonEmpty.vertex' 1       , NonEmpty.'NonEmpty.vertex' 2       ) ]
-- 'edgeList' $ scc (3 * 1 * 4 * 1 * 5) == [ (NonEmpty.'NonEmpty.vertex' 3       , NonEmpty.'NonEmpty.vertex' 5       )
--                                       , (NonEmpty.'NonEmpty.vertex' 3       , NonEmpty.'NonEmpty.clique1' [1,4,1])
--                                       , (NonEmpty.'NonEmpty.clique1' [1,4,1], NonEmpty.'NonEmpty.vertex' 5       ) ]
-- @
scc :: (Ord a) => AM.AdjacencyMap a -> AdjacencyMap (NAM.AdjacencyMap a)
scc = coerce AM.scc

-- | Construct an acyclic graph from a given adjacency map, or return 'Nothing'
-- if the input contains cycles.
--
-- @
-- toAcyclic ('AM.path'    [1,2,3]) == 'Just' (shrink $ 1 * 2 + 2 * 3)
-- toAcyclic ('AM.clique'  [3,2,1]) == 'Just' ('transpose' (shrink $ 1 * 2 * 3))
-- toAcyclic ('AM.circuit' [1,2,3]) == 'Nothing'
-- toAcyclic . 'fromAcyclic'     == 'Just'
-- @
toAcyclic :: Ord a => AM.AdjacencyMap a -> Maybe (AdjacencyMap a)
toAcyclic x = if AM.isAcyclic x then Just (AAM x) else Nothing

-- | Construct an acyclic graph from a given adjacency map, keeping only edges
-- @(x,y)@ where @x < y@ according to the supplied 'Ord' @a@ instance.
--
-- @
-- toAcyclicOrd 'empty'       == 'empty'
-- toAcyclicOrd . 'vertex'    == 'vertex'
-- toAcyclicOrd (1 + 2)     == shrink (1 + 2)
-- toAcyclicOrd (1 * 2)     == shrink (1 * 2)
-- toAcyclicOrd (2 * 1)     == shrink (1 + 2)
-- toAcyclicOrd (1 * 2 * 1) == shrink (1 * 2)
-- toAcyclicOrd (1 * 2 * 3) == shrink (1 * 2 * 3)
-- @
toAcyclicOrd :: Ord a => AM.AdjacencyMap a -> AdjacencyMap a
toAcyclicOrd = AAM . filterEdges (<)

-- TODO: Add time complexity
-- TODO: Change Arbitrary instance of Acyclic and Labelled Acyclic graph
-- | Construct an acyclic graph from a given adjacency map using 'scc'.
-- If the graph is acyclic, it is returned as is. If the graph is cyclic, then a
-- representative for every strongly connected component in its condensation
-- graph is chosen and these representatives are used to build an acyclic graph.
--
-- @
-- shrink . 'AM.vertex'      == 'vertex'
-- shrink . 'AM.vertices'    == 'vertices'
-- shrink . 'fromAcyclic' == 'id'
-- @
shrink :: Ord a => AM.AdjacencyMap a -> AdjacencyMap a
shrink = AAM . AM.gmap (NonEmpty.head . NAM.vertexList1) . AM.scc

-- TODO: Provide a faster equivalent in "Algebra.Graph.AdjacencyMap".
-- Keep only the edges that satisfy a given predicate.
filterEdges :: Ord a => (a -> a -> Bool) -> AM.AdjacencyMap a -> AM.AdjacencyMap a
filterEdges p m = AM.fromAdjacencySets
    [ (a, Set.filter (p a) bs) | (a, bs) <- Map.toList (AM.adjacencyMap m) ]

-- | Check if the internal representation of an acyclic graph is consistent,
-- i.e. that all edges refer to existing vertices and the graph is acyclic. It
-- should be impossible to create an inconsistent 'AdjacencyMap'.
--
-- @
-- consistent 'empty'                 == True
-- consistent ('vertex' x)            == True
-- consistent ('vertices' xs)         == True
-- consistent ('union' x y)           == True
-- consistent ('join' x y)            == True
-- consistent ('transpose' x)         == True
-- consistent ('box' x y)             == True
-- consistent ('transitiveClosure' x) == True
-- consistent ('scc' x)               == True
-- 'fmap' consistent ('toAcyclic' x)    /= False
-- consistent ('toAcyclicOrd' x)      == True
-- @
consistent :: Ord a => AdjacencyMap a -> Bool
consistent (AAM m) = AM.consistent m && AM.isAcyclic m