Graph.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Compat.Graph
-- Copyright   :  (c) Edward Z. Yang 2016
-- License     :  BSD3
--
-- Maintainer  :  cabal-dev@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- A data type representing directed graphs, backed by "Data.Graph".
-- It is strict in the node type.
--
-- This is an alternative interface to "Data.Graph".  In this interface,
-- nodes (identified by the 'IsNode' type class) are associated with a
-- key and record the keys of their neighbors.  This interface is more
-- convenient than 'Data.Graph.Graph', which requires vertices to be
-- explicitly handled by integer indexes.
--
-- The current implementation has somewhat peculiar performance
-- characteristics.  The asymptotics of all map-like operations mirror
-- their counterparts in "Data.Map".  However, to perform a graph
-- operation, we first must build the "Data.Graph" representation, an
-- operation that takes /O(V + E log V)/.  However, this operation can
-- be amortized across all queries on that particular graph.
--
-- Some nodes may be broken, i.e., refer to neighbors which are not
-- stored in the graph.  In our graph algorithms, we transparently
-- ignore such edges; however, you can easily query for the broken
-- vertices of a graph using 'broken' (and should, e.g., to ensure that
-- a closure of a graph is well-formed.)  It's possible to take a closed
-- subset of a broken graph and get a well-formed graph.
--
-----------------------------------------------------------------------------

module Distribution.Compat.Graph (
    -- * Graph type
    Graph,
    IsNode(..),
    -- * Query
    null,
    size,
    member,
    lookup,
    -- * Construction
    empty,
    insert,
    deleteKey,
    deleteLookup,
    -- * Combine
    unionLeft,
    unionRight,
    -- * Graph algorithms
    stronglyConnComp,
    SCC(..),
    cycles,
    broken,
    neighbors,
    revNeighbors,
    closure,
    revClosure,
    topSort,
    revTopSort,
    -- * Conversions
    -- ** Maps
    toMap,
    -- ** Lists
    fromDistinctList,
    toList,
    keys,
    -- ** Sets
    keysSet,
    -- ** Graphs
    toGraph,
    -- * Node type
    Node(..),
    nodeValue,
) where

-- For bootstrapping GHC
#ifdef MIN_VERSION_containers
#if MIN_VERSION_containers(0,5,0)
#define HAVE_containers_050
#endif
#endif

import Prelude ()
import qualified Distribution.Compat.Prelude as Prelude
import Distribution.Compat.Prelude hiding (lookup, null, empty)

import Data.Graph (SCC(..))
import qualified Data.Graph as G

#ifdef HAVE_containers_050
import qualified Data.Map.Strict as Map
#else
import qualified Data.Map as Map
#endif
import qualified Data.Set as Set
import qualified Data.Array as Array
import Data.Array ((!))
import qualified Data.Tree as Tree
import Data.Either (partitionEithers)
import qualified Data.Foldable as Foldable

-- | A graph of nodes @a@.  The nodes are expected to have instance
-- of class 'IsNode'.
data Graph a
    = Graph {
        graphMap          :: !(Map (Key a) a),
        -- Lazily cached graph representation
        graphForward      :: G.Graph,
        graphAdjoint      :: G.Graph,
        graphVertexToNode :: G.Vertex -> a,
        graphKeyToVertex  :: Key a -> Maybe G.Vertex,
        graphBroken       :: [(a, [Key a])]
    }
    deriving (Typeable)

-- NB: Not a Functor! (or Traversable), because you need
-- to restrict Key a ~ Key b.  We provide our own mapping
-- functions.

-- General strategy is most operations are deferred to the
-- Map representation.

instance Show a => Show (Graph a) where
    show = show . toList

instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where
    readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s)

instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where
    put x = put (toList x)
    get = fmap fromDistinctList get

instance (Eq (Key a), Eq a) => Eq (Graph a) where
    g1 == g2 = graphMap g1 == graphMap g2

instance Foldable.Foldable Graph where
    fold = Foldable.fold . graphMap
    foldr f z = Foldable.foldr f z . graphMap
    foldl f z = Foldable.foldl f z . graphMap
    foldMap f = Foldable.foldMap f . graphMap
#ifdef MIN_VERSION_base
#if MIN_VERSION_base(4,6,0)
    foldl' f z = Foldable.foldl' f z . graphMap
    foldr' f z = Foldable.foldr' f z . graphMap
#endif
#if MIN_VERSION_base(4,8,0)
    length = Foldable.length . graphMap
    null   = Foldable.null   . graphMap
    toList = Foldable.toList . graphMap
    elem x = Foldable.elem x . graphMap
    maximum = Foldable.maximum . graphMap
    minimum = Foldable.minimum . graphMap
    sum     = Foldable.sum     . graphMap
    product = Foldable.product . graphMap
#endif
#endif

instance (NFData a, NFData (Key a)) => NFData (Graph a) where
    rnf Graph {
        graphMap = m,
        graphForward = gf,
        graphAdjoint = ga,
        graphVertexToNode = vtn,
        graphKeyToVertex = ktv,
        graphBroken = b
    } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m

-- TODO: Data instance?

-- | The 'IsNode' class is used for datatypes which represent directed
-- graph nodes.  A node of type @a@ is associated with some unique key of
-- type @'Key' a@; given a node we can determine its key ('nodeKey')
-- and the keys of its neighbors ('nodeNeighbors').
class Ord (Key a) => IsNode a where
    type Key a :: *
    nodeKey :: a -> Key a
    nodeNeighbors :: a -> [Key a]

instance (IsNode a, IsNode b, Key a ~ Key b) => IsNode (Either a b) where
    type Key (Either a b) = Key a
    nodeKey (Left x)  = nodeKey x
    nodeKey (Right x) = nodeKey x
    nodeNeighbors (Left x)  = nodeNeighbors x
    nodeNeighbors (Right x) = nodeNeighbors x

-- | A simple, trivial data type which admits an 'IsNode' instance.
data Node k a = N a k [k]
    deriving (Show, Eq)

-- | Get the value from a 'Node'.
nodeValue :: Node k a -> a
nodeValue (N a _ _) = a

instance Functor (Node k) where
    fmap f (N a k ks) = N (f a) k ks

instance Ord k => IsNode (Node k a) where
    type Key (Node k a) = k
    nodeKey (N _ k _) = k
    nodeNeighbors (N _ _ ks) = ks

-- TODO: Maybe introduce a typeclass for items which just
-- keys (so, Key associated type, and nodeKey method).  But
-- I didn't need it here, so I didn't introduce it.

-- Query

-- | /O(1)/. Is the graph empty?
null :: Graph a -> Bool
null = Map.null . toMap

-- | /O(1)/. The number of nodes in the graph.
size :: Graph a -> Int
size = Map.size . toMap

-- | /O(log V)/. Check if the key is in the graph.
member :: IsNode a => Key a -> Graph a -> Bool
member k g = Map.member k (toMap g)

-- | /O(log V)/. Lookup the node at a key in the graph.
lookup :: IsNode a => Key a -> Graph a -> Maybe a
lookup k g = Map.lookup k (toMap g)

-- Construction

-- | /O(1)/. The empty graph.
empty :: IsNode a => Graph a
empty = fromMap Map.empty

-- | /O(log V)/. Insert a node into a graph.
insert :: IsNode a => a -> Graph a -> Graph a
insert !n g = fromMap (Map.insert (nodeKey n) n (toMap g))

-- | /O(log V)/. Delete the node at a key from the graph.
deleteKey :: IsNode a => Key a -> Graph a -> Graph a
deleteKey k g = fromMap (Map.delete k (toMap g))

-- | /O(log V)/. Lookup and delete.  This function returns the deleted
-- value if it existed.
deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a)
deleteLookup k g =
    let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g)
    in (r, fromMap m')

-- Combining

-- | /O(V + V')/. Right-biased union, preferring entries
-- from the second map when conflicts occur.
-- @'nodeKey' x = 'nodeKey' (f x)@.
unionRight :: IsNode a => Graph a -> Graph a -> Graph a
unionRight g g' = fromMap (Map.union (toMap g') (toMap g))

-- | /O(V + V')/. Left-biased union, preferring entries from
-- the first map when conflicts occur.
unionLeft :: IsNode a => Graph a -> Graph a -> Graph a
unionLeft = flip unionRight

-- Graph-like operations

-- | /Ω(V + E)/. Compute the strongly connected components of a graph.
-- Requires amortized construction of graph.
stronglyConnComp :: Graph a -> [SCC a]
stronglyConnComp g = map decode forest
  where
    forest = G.scc (graphForward g)
    decode (Tree.Node v [])
        | mentions_itself v = CyclicSCC  [graphVertexToNode g v]
        | otherwise         = AcyclicSCC (graphVertexToNode g v)
    decode other = CyclicSCC (dec other [])
        where dec (Tree.Node v ts) vs
                = graphVertexToNode g v : foldr dec vs ts
    mentions_itself v = v `elem` (graphForward g ! v)
-- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'.

-- | /Ω(V + E)/. Compute the cycles of a graph.
-- Requires amortized construction of graph.
cycles :: Graph a -> [[a]]
cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ]

-- | /O(1)/.  Return a list of nodes paired with their broken
-- neighbors (i.e., neighbor keys which are not in the graph).
-- Requires amortized construction of graph.
broken :: Graph a -> [(a, [Key a])]
broken g = graphBroken g

-- | Lookup the immediate neighbors from a key in the graph.
-- Requires amortized construction of graph.
neighbors :: Graph a -> Key a -> Maybe [a]
neighbors g k = do
    v <- graphKeyToVertex g k
    return (map (graphVertexToNode g) (graphForward g ! v))

-- | Lookup the immediate reverse neighbors from a key in the graph.
-- Requires amortized construction of graph.
revNeighbors :: Graph a -> Key a -> Maybe [a]
revNeighbors g k = do
    v <- graphKeyToVertex g k
    return (map (graphVertexToNode g) (graphAdjoint g ! v))

-- | Compute the subgraph which is the closure of some set of keys.
-- Returns @Nothing@ if one (or more) keys are not present in
-- the graph.
-- Requires amortized construction of graph.
closure :: Graph a -> [Key a] -> Maybe [a]
closure g ks = do
    vs <- traverse (graphKeyToVertex g) ks
    return (decodeVertexForest g (G.dfs (graphForward g) vs))

-- | Compute the reverse closure of a graph from some set
-- of keys.  Returns @Nothing@ if one (or more) keys are not present in
-- the graph.
-- Requires amortized construction of graph.
revClosure :: Graph a -> [Key a] -> Maybe [a]
revClosure g ks = do
    vs <- traverse (graphKeyToVertex g) ks
    return (decodeVertexForest g (G.dfs (graphAdjoint g) vs))

flattenForest :: Tree.Forest a -> [a]
flattenForest = concatMap Tree.flatten

decodeVertexForest :: Graph a -> Tree.Forest G.Vertex -> [a]
decodeVertexForest g = map (graphVertexToNode g) . flattenForest

-- | Topologically sort the nodes of a graph.
-- Requires amortized construction of graph.
topSort :: Graph a -> [a]
topSort g = map (graphVertexToNode g) $ G.topSort (graphForward g)

-- | Reverse topologically sort the nodes of a graph.
-- Requires amortized construction of graph.
revTopSort :: Graph a -> [a]
revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g)

-- Conversions

-- | /O(1)/. Convert a map from keys to nodes into a graph.
-- The map must satisfy the invariant that
-- @'fromMap' m == 'fromList' ('Data.Map.elems' m)@;
-- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@
-- instead.  The values of the map are assumed to already
-- be in WHNF.
fromMap :: IsNode a => Map (Key a) a -> Graph a
fromMap m
    = Graph { graphMap = m
            -- These are lazily computed!
            , graphForward = g
            , graphAdjoint = G.transposeG g
            , graphVertexToNode = vertex_to_node
            , graphKeyToVertex = key_to_vertex
            , graphBroken = broke
            }
  where
    try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k)

    (brokenEdges, edges)
        = unzip
        $ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n))
          | n <- ns ]
    broke = filter (not . Prelude.null . snd) (zip ns brokenEdges)

    g = Array.listArray bounds edges

    ns              = Map.elems m -- sorted ascending
    vertices        = zip (map nodeKey ns) [0..]
    vertex_map      = Map.fromAscList vertices
    key_to_vertex k = Map.lookup k vertex_map

    vertex_to_node vertex = nodeTable ! vertex

    nodeTable   = Array.listArray bounds ns
    bounds = (0, Map.size m - 1)

-- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph.
fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a
fromDistinctList = fromMap
                 . Map.fromListWith (\_ -> duplicateError)
                 . map (\n -> n `seq` (nodeKey n, n))
  where
    duplicateError n = error $ "Graph.fromDistinctList: duplicate key: "
                            ++ show (nodeKey n)

-- Map-like operations

-- | /O(V)/. Convert a graph into a list of nodes.
toList :: Graph a -> [a]
toList g = Map.elems (toMap g)

-- | /O(V)/. Convert a graph into a list of keys.
keys :: Graph a -> [Key a]
keys g = Map.keys (toMap g)

-- | /O(V)/. Convert a graph into a set of keys.
keysSet :: Graph a -> Set.Set (Key a)
keysSet g = Map.keysSet (toMap g)

-- | /O(1)/. Convert a graph into a map from keys to nodes.
-- The resulting map @m@ is guaranteed to have the property that
-- @'Prelude.all' (\(k,n) -> k == 'nodeKey' n) ('Data.Map.toList' m)@.
toMap :: Graph a -> Map (Key a) a
toMap = graphMap

-- Graph-like operations

-- | /O(1)/. Convert a graph into a 'Data.Graph.Graph'.
-- Requires amortized construction of graph.
toGraph :: Graph a -> (G.Graph, G.Vertex -> a, Key a -> Maybe G.Vertex)
toGraph g = (graphForward g, graphVertexToNode g, graphKeyToVertex g)