Commit 74917562 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Add Distribution.Compat.Graph, fixes #3521.

parent d3259408
......@@ -273,6 +273,7 @@ library
Distribution.Compat.CreatePipe
Distribution.Compat.Environment
Distribution.Compat.Exception
Distribution.Compat.Graph
Distribution.Compat.Internal.TempFile
Distribution.Compat.ReadP
Distribution.Compat.Semigroup
......@@ -377,6 +378,7 @@ test-suite unit-tests
UnitTests.Distribution.Compat.CreatePipe
UnitTests.Distribution.Compat.ReadP
UnitTests.Distribution.Compat.Time
UnitTests.Distribution.Compat.Graph
UnitTests.Distribution.Simple.Program.Internal
UnitTests.Distribution.Simple.Utils
UnitTests.Distribution.System
......@@ -384,7 +386,9 @@ test-suite unit-tests
UnitTests.Distribution.Version
main-is: UnitTests.hs
build-depends:
array,
base,
containers,
directory,
filepath,
tasty,
......
{-# 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,
lookup,
-- * Construction
empty,
insert,
deleteKey,
deleteLookup,
-- * Combine
unionLeft,
unionRight,
-- * Graph algorithms
stronglyConnComp,
SCC(..),
cycles,
broken,
closure,
revClosure,
topSort,
revTopSort,
-- * Conversions
-- ** Maps
toMap,
-- ** Lists
fromList,
toList,
keys,
-- ** Graphs
toGraph,
-- * Node type
Node(..),
nodeValue,
) where
import qualified Prelude as Prelude
import Prelude hiding (lookup, null)
import Data.Graph (SCC(..))
import qualified Data.Graph as G
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Array as Array
import Data.Array ((!))
import qualified Data.Tree as Tree
import Data.Either
import Data.Typeable
import qualified Data.Foldable as Foldable
import Control.DeepSeq
import Distribution.Compat.Binary (Binary(..))
-- | 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) => Read (Graph a) where
readsPrec d s = map (\(a,r) -> (fromList a, r)) (readsPrec d s)
instance (IsNode a, Binary a) => Binary (Graph a) where
put x = put (toList x)
get = fmap fromList 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]
-- | 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 with 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)/. 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 g g' = fromMap (Map.union (toMap g) (toMap g'))
-- 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
-- | 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 <- mapM (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 <- mapM (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 into a graph.
fromList :: IsNode a => [a] -> Graph a
fromList ns = fromMap
. Map.fromList
. map (\n -> n `seq` (nodeKey n, n))
$ ns
-- 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(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)
......@@ -16,6 +16,7 @@ import Distribution.Compat.Time
import qualified UnitTests.Distribution.Compat.CreatePipe
import qualified UnitTests.Distribution.Compat.ReadP
import qualified UnitTests.Distribution.Compat.Time
import qualified UnitTests.Distribution.Compat.Graph
import qualified UnitTests.Distribution.Simple.Program.Internal
import qualified UnitTests.Distribution.Simple.Utils
import qualified UnitTests.Distribution.System
......@@ -36,6 +37,8 @@ tests mtimeChangeCalibrated =
UnitTests.Distribution.Compat.ReadP.tests
, testGroup "Distribution.Compat.Time"
(UnitTests.Distribution.Compat.Time.tests mtimeChange)
, testGroup "Distribution.Compat.Graph"
UnitTests.Distribution.Compat.Graph.tests
, testGroup "Distribution.Simple.Program.Internal"
UnitTests.Distribution.Simple.Program.Internal.tests
, testGroup "Distribution.Simple.Utils"
......
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module UnitTests.Distribution.Compat.Graph
( tests
, arbitraryGraph
) where
import Distribution.Compat.Graph
import qualified Prelude
import Prelude hiding (null)
import Test.Tasty
import Test.Tasty.QuickCheck
import qualified Data.Set as Set
import Control.Monad
import qualified Data.Graph as G
import Data.Array ((!))
import Data.Maybe
import Data.List (sort)
tests :: [TestTree]
tests =
[ testProperty "arbitrary unbroken" (prop_arbitrary_unbroken :: Graph (Node Int ()) -> Bool)
, testProperty "nodes consistent" (prop_nodes_consistent :: Graph (Node Int ()) -> Bool)
, testProperty "edges consistent" (prop_edges_consistent :: Graph (Node Int ()) -> Property)
, testProperty "closure consistent" (prop_closure_consistent :: Graph (Node Int ()) -> Property)
]
-- Our arbitrary instance does not generate broken graphs
prop_arbitrary_unbroken :: Graph a -> Bool
prop_arbitrary_unbroken g = Prelude.null (broken g)
-- Every node from 'toList' maps to a vertex which
-- is present in the constructed graph, and maps back
-- to a node correctly.
prop_nodes_consistent :: (Eq a, IsNode a) => Graph a -> Bool
prop_nodes_consistent g = all p (toList g)
where
(_, vtn, ktv) = toGraph g
p n = case ktv (nodeKey n) of
Just v -> vtn v == n
Nothing -> False
-- A non-broken graph has the 'nodeNeighbors' of each node
-- equal the recorded adjacent edges in the node graph.
prop_edges_consistent :: IsNode a => Graph a -> Property
prop_edges_consistent g = Prelude.null (broken g) ==> all p (toList g)
where
(gr, vtn, ktv) = toGraph g
p n = sort (nodeNeighbors n)
== sort (map (nodeKey . vtn) (gr ! fromJust (ktv (nodeKey n))))
-- Closure is consistent with reachable
prop_closure_consistent :: (Show a, IsNode a) => Graph a -> Property
prop_closure_consistent g =
not (null g) ==>
forAll (elements (toList g)) $ \n ->
Set.fromList (map nodeKey (fromJust (closure g [nodeKey n])))
== Set.fromList (map (nodeKey . vtn) (G.reachable gr (fromJust (ktv (nodeKey n)))))
where
(gr, vtn, ktv) = toGraph g
hasNoDups :: Ord a => [a] -> Bool
hasNoDups = loop Set.empty
where
loop _ [] = True
loop s (x:xs) | s' <- Set.insert x s, Set.size s' > Set.size s
= loop s' xs
| otherwise
= False
arbitraryGraph :: (Ord k, Arbitrary k, Arbitrary a) => Int -> Gen (Graph (Node k a))
arbitraryGraph len = do
-- Careful! Assume k is much larger than size.
ks <- vectorOf len arbitrary `suchThat` hasNoDups
ns <- forM ks $ \k -> do
a <- arbitrary
neighbors <- listOf (elements ks)
-- Allow duplicates!
return (N a k neighbors)
return (fromList ns)
instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (Graph (Node k a)) where
arbitrary = sized $ \n -> do
len <- choose (0, n)
arbitraryGraph len
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment