Graph.hs 13.4 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
{-# 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,
49
    member,
50
51
52
53
54
55
56
57
58
59
60
61
62
63
    lookup,
    -- * Construction
    empty,
    insert,
    deleteKey,
    deleteLookup,
    -- * Combine
    unionLeft,
    unionRight,
    -- * Graph algorithms
    stronglyConnComp,
    SCC(..),
    cycles,
    broken,
64
65
    neighbors,
    revNeighbors,
66
67
68
69
70
71
72
73
    closure,
    revClosure,
    topSort,
    revTopSort,
    -- * Conversions
    -- ** Maps
    toMap,
    -- ** Lists
74
    fromDistinctList,
75
76
    toList,
    keys,
77
78
    -- ** Sets
    keysSet,
79
80
81
82
83
84
85
    -- ** Graphs
    toGraph,
    -- * Node type
    Node(..),
    nodeValue,
) where

Ben Gamari's avatar
Ben Gamari committed
86
87
88
89
90
91
92
-- For bootstrapping GHC
#ifdef MIN_VERSION_containers
#if MIN_VERSION_containers(0,5,0)
#define HAVE_containers_050
#endif
#endif

93
94
95
96
import Prelude ()
import qualified Distribution.Compat.Prelude as Prelude
import Distribution.Compat.Prelude hiding (lookup, null, empty)

97
98
import Data.Graph (SCC(..))
import qualified Data.Graph as G
Ben Gamari's avatar
Ben Gamari committed
99
100

#ifdef HAVE_containers_050
101
102
import qualified Data.Map.Strict as Map
#else
103
import qualified Data.Map as Map
104
#endif
105
import qualified Data.Set as Set
106
107
108
import qualified Data.Array as Array
import Data.Array ((!))
import qualified Data.Tree as Tree
109
import Data.Either (partitionEithers)
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
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

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

139
instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where
140
    put x = put (toList x)
141
    get = fmap fromDistinctList get
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188

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]

189
190
191
192
193
194
195
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

196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
-- | 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

212
-- TODO: Maybe introduce a typeclass for items which just
213
214
215
216
217
218
219
220
221
222
223
224
225
-- 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

226
227
228
229
-- | /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)

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
-- | /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
266
unionLeft = flip unionRight
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295

-- 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

296
297
-- | Lookup the immediate neighbors from a key in the graph.
-- Requires amortized construction of graph.
298
neighbors :: Graph a -> Key a -> Maybe [a]
299
300
301
302
303
304
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.
305
revNeighbors :: Graph a -> Key a -> Maybe [a]
306
307
308
309
revNeighbors g k = do
    v <- graphKeyToVertex g k
    return (map (graphVertexToNode g) (graphAdjoint g ! v))

310
311
312
313
314
315
-- | 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
316
    vs <- traverse (graphKeyToVertex g) ks
317
318
319
320
321
322
323
324
    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
325
    vs <- traverse (graphKeyToVertex g) ks
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
    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)

383
384
385
386
387
388
389
390
-- | /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)
391
392
393
394
395
396
397
398
399
400
401

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

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

406
407
408
409
410
411
412
413
414
415
416
417
-- | /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)