-
Notifications
You must be signed in to change notification settings - Fork 1
/
DirectAcyclicHyperGraph.hs
614 lines (502 loc) · 20.6 KB
/
DirectAcyclicHyperGraph.hs
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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
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
136
137
138
139
140
141
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
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
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
266
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
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
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
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
{-# LANGUAGE CPP #-}
-- (c) 1999-2005 by Martin Erwig [see file COPYRIGHT]
-- (c) 2018 by code Dotation to Enqm
-- | Static and Dynamic Inductive Graphs
module Enqm.DirectAcyclicHyperGraph (
-- * General Type Defintions
-- ** Node and Edge Types
Node,LNode,UNode,
Edge,LEdge,UEdge,
-- ** Types Supporting Inductive Graph View
Adj,Context,MContext,Decomp,GDecomp,UContext,UDecomp,
Path,LPath(..),UPath,
-- * Graph Type Classes
-- | We define two graph classes:
--
-- Graph: static, decomposable graphs.
-- Static means that a graph itself cannot be changed
--
-- DynGraph: dynamic, extensible graphs.
-- Dynamic graphs inherit all operations from static graphs
-- but also offer operations to extend and change graphs.
--
-- Each class contains in addition to its essential operations those
-- derived operations that might be overwritten by a more efficient
-- implementation in an instance definition.
--
-- Note that labNodes is essentially needed because the default definition
-- for matchAny is based on it: we need some node from the graph to define
-- matchAny in terms of match. Alternatively, we could have made matchAny
-- essential and have labNodes defined in terms of ufold and matchAny.
-- However, in general, labNodes seems to be (at least) as easy to define
-- as matchAny. We have chosen labNodes instead of the function nodes since
-- nodes can be easily derived from labNodes, but not vice versa.
Graph(..),
DynGraph(..),
-- * Operations
order,
size,
-- ** Graph Folds and Maps
ufold,gmap,nmap,emap,nemap,
-- ** Graph Projection
nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem,
-- ** Graph Construction and Destruction
insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge,
insNodes,insEdges,delNodes,delEdges,
buildGr,mkUGraph,
-- ** Subgraphs
gfiltermap,nfilter,labnfilter,labfilter,subgraph,
-- ** Graph Inspection
context,lab,neighbors,lneighbors,
suc,pre,lsuc,lpre,
out,inn,outdeg,indeg,deg,
hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj,
equal,
-- ** Context Inspection
node',lab',labNode',neighbors',lneighbors',
suc',pre',lpre',lsuc',
out',inn',outdeg',indeg',deg',
-- * Pretty-printing
prettify,
prettyPrint,
-- * Ordering of Graphs
OrdGr(..)
) where
import Control.Arrow (first)
import Data.Function (on)
import qualified Data.IntSet as IntSet
import Data.List (delete, foldl', groupBy, sort, sortBy, (\\))
import Data.Maybe (fromMaybe, isJust)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (mappend)
#endif
-- | Unlabeled node
type Node = Int
-- | Labeled node
type LNode a = (Node,a)
-- | Quasi-unlabeled node
type UNode = LNode ()
-- | Unlabeled edge
data Edge = Edge (Node,Node)
| Hyper ([Node],[Node])
deriving (Show,Read,Eq,Ord)
-- | Labeled edge
data LEdge b = LEdge (Node,Node,b)
| LHyper ([Node],[Node],b)
deriving (Show,Read,Eq,Ord)
-- | Quasi-unlabeled edge
type UEdge = LEdge ()
-- | Unlabeled path
type Path = [Node]
-- | Labeled path
newtype LPath a = LP { unLPath :: [LNode a] }
instance (Show a) => Show (LPath a) where
show (LP xs) = show xs
instance (Eq a) => Eq (LPath a) where
(LP []) == (LP []) = True
(LP ((_,x):_)) == (LP ((_,y):_)) = x==y
(LP _) == (LP _) = False
instance (Ord a) => Ord (LPath a) where
compare (LP []) (LP []) = EQ
compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y
compare _ _ = error "LPath: cannot compare two empty paths"
-- | Quasi-unlabeled path
type UPath = [UNode]
-- | Labeled links to or from a 'Node'.
type Adj b = [(b,Node)]
-- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'.
--
-- In other words, this captures all information regarding the
-- specified 'Node' within a graph.
type Context a b = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node
type MContext a b = Maybe (Context a b)
-- | 'Graph' decomposition - the context removed from a 'Graph', and the rest
-- of the 'Graph'.
type Decomp g a b = (MContext a b,g a b)
-- | The same as 'Decomp', only more sure of itself.
type GDecomp g a b = (Context a b,g a b)
-- | Unlabeled context.
type UContext = ([Node],Node,[Node])
-- | Unlabeled decomposition.
type UDecomp g = (Maybe UContext,g)
-- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes'
class Graph gr where
{-# MINIMAL empty, isEmpty, match, mkGraph, labNodes #-}
-- | An empty 'Graph'.
empty :: gr a b
-- | True if the given 'Graph' is empty.
isEmpty :: gr a b -> Bool
-- | Decompose a 'Graph' into the 'MContext' found for the given node and the
-- remaining 'Graph'.
match :: Node -> gr a b -> Decomp gr a b
-- | Create a 'Graph' from the list of 'LNode's and 'LEdge's.
--
-- For graphs that are also instances of 'DynGraph', @mkGraph ns
-- es@ should be equivalent to @('insEdges' es . 'insNodes' ns)
-- 'empty'@.
mkGraph :: [LNode a] -> [LEdge b] -> gr a b
-- | A list of all 'LNode's in the 'Graph'.
labNodes :: gr a b -> [LNode a]
-- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node'
-- and the remaining 'Graph'.
matchAny :: gr a b -> GDecomp gr a b
matchAny g = case labNodes g of
[] -> error "Match Exception, Empty Graph"
(v,_):_ -> (c,g')
where
(Just c,g') = match v g
-- | The number of 'Node's in a 'Graph'.
noNodes :: gr a b -> Int
noNodes = length . labNodes
-- | The minimum and maximum 'Node' in a 'Graph'.
nodeRange :: gr a b -> (Node,Node)
nodeRange g
| isEmpty g = error "nodeRange of empty graph"
| otherwise = (minimum vs, maximum vs)
where
vs = nodes g
-- | A list of all 'LEdge's in the 'Graph'.
labEdges :: gr a b -> [LEdge b]
labEdges = ufold (\(_,v,_,s)->(map (\(l,w)-> LEdge (v,w,l)) s ++)) []
class (Graph gr) => DynGraph gr where
-- | Merge the 'Context' into the 'DynGraph'.
--
-- Context adjacencies should only refer to either a Node already
-- in a graph or the node in the Context itself (for loops).
--
-- Behaviour is undefined if the specified 'Node' already exists
-- in the graph.
(&) :: Context a b -> gr a b -> gr a b
-- | The number of nodes in the graph. An alias for 'noNodes'.
order :: (Graph gr) => gr a b -> Int
order = noNodes
-- | The number of edges in the graph.
--
-- Note that this counts every edge found, so if you are
-- representing an unordered graph by having each edge mirrored this
-- will be incorrect.
--
-- If you created an unordered graph by either mirroring every edge
-- (including loops!) or using the @undir@ function in
-- "Data.Graph.Inductive.Basic" then you can safely halve the value
-- returned by this.
size :: (Graph gr) => gr a b -> Int
size = length . labEdges
-- | Fold a function over the graph by recursively calling 'match'.
ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c
ufold f u g
| isEmpty g = u
| otherwise = f c (ufold f u g')
where
(c,g') = matchAny g
-- | Map a function over the graph by recursively calling 'match'.
gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d
gmap f = ufold (\c->(f c&)) empty
{-# NOINLINE [0] gmap #-}
-- | Map a function over the 'Node' labels in a graph.
nmap :: (DynGraph gr) => (a -> c) -> gr a b -> gr c b
nmap f = gmap (\(p,v,l,s)->(p,v,f l,s))
{-# NOINLINE [0] nmap #-}
-- | Map a function over the 'Edge' labels in a graph.
emap :: (DynGraph gr) => (b -> c) -> gr a b -> gr a c
emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s))
where
map1 g = map (first g)
{-# NOINLINE [0] emap #-}
-- | Map functions over both the 'Node' and 'Edge' labels in a graph.
nemap :: (DynGraph gr) => (a -> c) -> (b -> d) -> gr a b -> gr c d
nemap fn fe = gmap (\(p,v,l,s) -> (fe' p,v,fn l,fe' s))
where
fe' = map (first fe)
{-# NOINLINE [0] nemap #-}
-- | List all 'Node's in the 'Graph'.
nodes :: (Graph gr) => gr a b -> [Node]
nodes = map fst . labNodes
-- | List all 'Edge's in the 'Graph'.
edges :: (Graph gr) => gr a b -> [Edge]
edges = map toEdge . labEdges
-- | Drop the label component of an edge.
toEdge :: LEdge b -> Edge
toEdge (LEdge (v,w,_)) = Edge (v,w)
-- | Add a label to an edge.
toLEdge :: Edge -> b -> LEdge b
toLEdge (Edge (v,w)) l = LEdge (v,w,l)
-- | The label in an edge.
edgeLabel :: LEdge b -> b
edgeLabel (LEdge (_,_,l)) = l
-- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'.
newNodes :: (Graph gr) => Int -> gr a b -> [Node]
newNodes i g
| isEmpty g = [0..i-1]
| otherwise = [n+1..n+i]
where
(_,n) = nodeRange g
-- | 'True' if the 'Node' is present in the 'Graph'.
gelem :: (Graph gr) => Node -> gr a b -> Bool
gelem v = isJust . fst . match v
-- | Insert a 'LNode' into the 'Graph'.
insNode :: (DynGraph gr) => LNode a -> gr a b -> gr a b
insNode (v,l) = (([],v,l,[])&)
{-# NOINLINE [0] insNode #-}
-- | Insert a 'LEdge' into the 'Graph'.
insEdge :: (DynGraph gr) => LEdge b -> gr a b -> gr a b
insEdge (LEdge (v,w,l)) g = (pr,v,la,(l,w):su) & g'
where
(mcxt,g') = match v g
(pr,_,la,su) = fromMaybe
(error ("insEdge: cannot add edge from non-existent vertex " ++ show v))
mcxt
{-# NOINLINE [0] insEdge #-}
-- | Remove a 'Node' from the 'Graph'.
delNode :: (Graph gr) => Node -> gr a b -> gr a b
delNode v = delNodes [v]
-- | Remove an 'Edge' from the 'Graph'.
--
-- NOTE: in the case of multiple edges, this will delete /all/ such
-- edges from the graph as there is no way to distinguish between
-- them. If you need to delete only a single such edge, please use
-- 'delLEdge'.
delEdge :: (DynGraph gr) => Edge -> gr a b -> gr a b
delEdge (Edge (v,w)) g = case match v g of
(Nothing,_) -> g
(Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g'
-- | Remove an 'LEdge' from the 'Graph'.
--
-- NOTE: in the case of multiple edges with the same label, this
-- will only delete the /first/ such edge. To delete all such
-- edges, please use 'delAllLedge'.
delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b
delLEdge = delLEdgeBy delete
-- | Remove all edges equal to the one specified.
delAllLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b
delAllLEdge = delLEdgeBy (filter . (/=))
delLEdgeBy :: (DynGraph gr) => ((b,Node) -> Adj b -> Adj b)
-> LEdge b -> gr a b -> gr a b
delLEdgeBy f (LEdge (v,w,b)) g = case match v g of
(Nothing,_) -> g
(Just (p,v',l,s),g') -> (p,v',l,f (b,w) s) & g'
-- | Insert multiple 'LNode's into the 'Graph'.
insNodes :: (DynGraph gr) => [LNode a] -> gr a b -> gr a b
insNodes vs g = foldl' (flip insNode) g vs
{-# INLINABLE insNodes #-}
-- | Insert multiple 'LEdge's into the 'Graph'.
insEdges :: (DynGraph gr) => [LEdge b] -> gr a b -> gr a b
insEdges es g = foldl' (flip insEdge) g es
{-# INLINABLE insEdges #-}
-- | Remove multiple 'Node's from the 'Graph'.
delNodes :: (Graph gr) => [Node] -> gr a b -> gr a b
delNodes vs g = foldl' (snd .: flip match) g vs
-- | Remove multiple 'Edge's from the 'Graph'.
delEdges :: (DynGraph gr) => [Edge] -> gr a b -> gr a b
delEdges es g = foldl' (flip delEdge) g es
-- | Build a 'Graph' from a list of 'Context's.
--
-- The list should be in the order such that earlier 'Context's
-- depend upon later ones (i.e. as produced by @'ufold' (:) []@).
buildGr :: (DynGraph gr) => [Context a b] -> gr a b
buildGr = foldr (&) empty
-- | Build a quasi-unlabeled 'Graph'.
mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () ()
mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es)
where
labUEdges = map (`toLEdge` ())
labUNodes = map (flip (,) ())
-- | Build a graph out of the contexts for which the predicate is
-- satisfied by recursively calling 'match'.
gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d
gfiltermap f = ufold (maybe id (&) . f) empty
-- | Returns the subgraph only containing the labelled nodes which
-- satisfy the given predicate.
labnfilter :: Graph gr => (LNode a -> Bool) -> gr a b -> gr a b
labnfilter p gr = delNodes (map fst . filter (not . p) $ labNodes gr) gr
-- | Returns the subgraph only containing the nodes which satisfy the
-- given predicate.
nfilter :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b
nfilter f = labnfilter (f . fst)
-- | Returns the subgraph only containing the nodes whose labels
-- satisfy the given predicate.
labfilter :: DynGraph gr => (a -> Bool) -> gr a b -> gr a b
labfilter f = labnfilter (f . snd)
-- | Returns the subgraph induced by the supplied nodes.
subgraph :: DynGraph gr => [Node] -> gr a b -> gr a b
subgraph vs = let vs' = IntSet.fromList vs
in nfilter (`IntSet.member` vs')
-- | Find the context for the given 'Node'. Causes an error if the 'Node' is
-- not present in the 'Graph'.
context :: (Graph gr) => gr a b -> Node -> Context a b
context g v = fromMaybe (error ("Match Exception, Node: "++show v))
(fst (match v g))
-- | Find the label for a 'Node'.
lab :: (Graph gr) => gr a b -> Node -> Maybe a
lab g v = fmap lab' . fst $ match v g
-- | Find the neighbors for a 'Node'.
neighbors :: (Graph gr) => gr a b -> Node -> [Node]
neighbors = map snd .: lneighbors
-- | Find the labelled links coming into or going from a 'Context'.
lneighbors :: (Graph gr) => gr a b -> Node -> Adj b
lneighbors = maybe [] lneighbors' .: mcontext
-- | Find all 'Node's that have a link from the given 'Node'.
suc :: (Graph gr) => gr a b -> Node -> [Node]
suc = map snd .: context4l
-- | Find all 'Node's that link to to the given 'Node'.
pre :: (Graph gr) => gr a b -> Node -> [Node]
pre = map snd .: context1l
-- | Find all 'Node's that are linked from the given 'Node' and the label of
-- each link.
lsuc :: (Graph gr) => gr a b -> Node -> [(Node,b)]
lsuc = map flip2 .: context4l
-- | Find all 'Node's that link to the given 'Node' and the label of each link.
lpre :: (Graph gr) => gr a b -> Node -> [(Node,b)]
lpre = map flip2 .: context1l
-- | Find all outward-bound 'LEdge's for the given 'Node'.
out :: (Graph gr) => gr a b -> Node -> [LEdge b]
out g v = map (\(l,w)->LEdge (v,w,l)) (context4l g v)
-- | Find all inward-bound 'LEdge's for the given 'Node'.
inn :: (Graph gr) => gr a b -> Node -> [LEdge b]
inn g v = map (\(l,w)->LEdge (w,v,l)) (context1l g v)
-- | The outward-bound degree of the 'Node'.
outdeg :: (Graph gr) => gr a b -> Node -> Int
outdeg = length .: context4l
-- | The inward-bound degree of the 'Node'.
indeg :: (Graph gr) => gr a b -> Node -> Int
indeg = length .: context1l
-- | The degree of the 'Node'.
deg :: (Graph gr) => gr a b -> Node -> Int
deg = deg' .: context
-- | The 'Node' in a 'Context'.
node' :: Context a b -> Node
node' (_,v,_,_) = v
-- | The label in a 'Context'.
lab' :: Context a b -> a
lab' (_,_,l,_) = l
-- | The 'LNode' from a 'Context'.
labNode' :: Context a b -> LNode a
labNode' (_,v,l,_) = (v,l)
-- | All 'Node's linked to or from in a 'Context'.
neighbors' :: Context a b -> [Node]
neighbors' (p,_,_,s) = map snd p++map snd s
-- | All labelled links coming into or going from a 'Context'.
lneighbors' :: Context a b -> Adj b
lneighbors' (p,_,_,s) = p ++ s
-- | All 'Node's linked to in a 'Context'.
suc' :: Context a b -> [Node]
suc' = map snd . context4l'
-- | All 'Node's linked from in a 'Context'.
pre' :: Context a b -> [Node]
pre' = map snd . context1l'
-- | All 'Node's linked from in a 'Context', and the label of the links.
lsuc' :: Context a b -> [(Node,b)]
lsuc' = map flip2 . context4l'
-- | All 'Node's linked from in a 'Context', and the label of the links.
lpre' :: Context a b -> [(Node,b)]
lpre' = map flip2 . context1l'
-- | All outward-directed 'LEdge's in a 'Context'.
out' :: Context a b -> [LEdge b]
out' c@(_,v,_,_) = map (\(l,w)->LEdge (v,w,l)) (context4l' c)
-- | All inward-directed 'LEdge's in a 'Context'.
inn' :: Context a b -> [LEdge b]
inn' c@(_,v,_,_) = map (\(l,w)-> LEdge (w,v,l)) (context1l' c)
-- | The outward degree of a 'Context'.
outdeg' :: Context a b -> Int
outdeg' = length . context4l'
-- | The inward degree of a 'Context'.
indeg' :: Context a b -> Int
indeg' = length . context1l'
-- | The degree of a 'Context'.
deg' :: Context a b -> Int
deg' (p,_,_,s) = length p+length s
-- | Checks if there is a directed edge between two nodes.
hasEdge :: Graph gr => gr a b -> Edge -> Bool
hasEdge gr (Edge (v,w)) = w `elem` suc gr v
-- | Checks if there is an undirected edge between two nodes.
hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool
hasNeighbor gr v w = w `elem` neighbors gr v
-- | Checks if there is a labelled edge between two nodes.
hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool
hasLEdge gr (LEdge (v,w,l)) = (w,l) `elem` lsuc gr v
-- | Checks if there is an undirected labelled edge between two nodes.
hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> (b,Node) -> Bool
hasNeighborAdj gr v a = a `elem` lneighbors gr v
----------------------------------------------------------------------
-- GRAPH EQUALITY
----------------------------------------------------------------------
slabNodes :: (Graph gr) => gr a b -> [LNode a]
slabNodes = sortBy (compare `on` fst) . labNodes
glabEdges :: (Graph gr) => gr a b -> [GroupEdges b]
glabEdges = map (GEs . groupLabels)
. groupBy ((==) `on` toEdge)
. sortBy (compare `on` toEdge)
. labEdges
where
groupLabels les = toLEdge (toEdge (head les)) (map edgeLabel les)
equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool
equal g g' = slabNodes g == slabNodes g' && glabEdges g == glabEdges g'
-- This assumes that nodes aren't repeated (which shouldn't happen for
-- sane graph instances). If node IDs are repeated, then the usage of
-- slabNodes cannot guarantee stable ordering.
-- Newtype wrapper just to test for equality of multiple edges. This
-- is needed because without an Ord constraint on `b' it is not
-- possible to guarantee a stable ordering on edge labels.
newtype GroupEdges b = GEs (LEdge [b])
deriving (Show, Read)
instance (Eq b) => Eq (GroupEdges b) where
(GEs (LEdge (v1,w1,bs1))) == (GEs (LEdge (v2,w2,bs2))) = v1 == v2
&& w1 == w2
&& eqLists bs1 bs2
eqLists :: (Eq a) => [a] -> [a] -> Bool
eqLists xs ys = null (xs \\ ys) && null (ys \\ xs)
-- OK to use \\ here as we want each value in xs to cancel a *single*
-- value in ys.
----------------------------------------------------------------------
-- UTILITIES
----------------------------------------------------------------------
-- auxiliary functions used in the implementation of the
-- derived class members
--
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
-- f .: g = \x y->f (g x y)
-- f .: g = (f .) . g
-- (.:) f = ((f .) .)
-- (.:) = (.) (.) (.)
(.:) = (.) . (.)
flip2 :: (a,b) -> (b,a)
flip2 (x,y) = (y,x)
-- projecting on context elements
--
context1l :: (Graph gr) => gr a b -> Node -> Adj b
context1l = maybe [] context1l' .: mcontext
context4l :: (Graph gr) => gr a b -> Node -> Adj b
context4l = maybe [] context4l' .: mcontext
mcontext :: (Graph gr) => gr a b -> Node -> MContext a b
mcontext = fst .: flip match
context1l' :: Context a b -> Adj b
context1l' (p,v,_,s) = p++filter ((==v).snd) s
context4l' :: Context a b -> Adj b
context4l' (p,v,_,s) = s++filter ((==v).snd) p
----------------------------------------------------------------------
-- PRETTY PRINTING
----------------------------------------------------------------------
-- | Pretty-print the graph. Note that this loses a lot of
-- information, such as edge inverses, etc.
prettify :: (DynGraph gr, Show a, Show b) => gr a b -> String
prettify g = foldr (showsContext . context g) id (nodes g) ""
where
showsContext (_,n,l,s) sg = shows n . (':':) . shows l
. showString "->" . shows s
. ('\n':) . sg
-- | Pretty-print the graph to stdout.
prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO ()
prettyPrint = putStr . prettify
----------------------------------------------------------------------
-- Ordered Graph
----------------------------------------------------------------------
-- | OrdGr comes equipped with an Ord instance, so that graphs can be
-- used as e.g. Map keys.
newtype OrdGr gr a b = OrdGr { unOrdGr :: gr a b }
deriving (Read,Show)
instance (Graph gr, Ord a, Ord b) => Eq (OrdGr gr a b) where
g1 == g2 = compare g1 g2 == EQ
instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where
compare (OrdGr g1) (OrdGr g2) =
(compare `on` sort . labNodes) g1 g2
`mappend` (compare `on` sort . labEdges) g1 g2