{-# 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)