Commit | Line | Data |
---|---|---|
5a07db44 MM |
1 | -- I wrote this to help with NaiveMinCostFlow but abandoned it. Wrapping is |
2 | -- more trouble than it's worth, and NaiveMinCostFlow needs access to its ST | |
3 | -- monad in the edge-filtering test, which would have required more mess here. | |
4 | ||
5 | module GraphStuff where | |
6 | import Data.Graph.Inductive.Graph | |
7 | ||
8 | data EdgeMapper b1 b2 = EdgeMapper { | |
9 | -- Map the predecessor and successor edges of the given node for a context. | |
10 | mapAdj :: Node -> (Adj b1, Adj b1) -> (Adj b2, Adj b2), | |
11 | -- For labEdges. Should be consistent with the above two!!! | |
12 | mapLEdge :: LEdge b1 -> [LEdge b2] | |
13 | } | |
14 | ||
15 | data EdgeMappedGraph a b = forall gr b1. Graph gr => EdgeMappedGraph { | |
16 | emgMapper :: EdgeMapper b1 b, | |
17 | emgOrig :: gr a b1 | |
18 | } | |
19 | ||
20 | edgeMapContext :: EdgeMapper b1 b2 -> Context a b1 -> Context a b2 | |
21 | edgeMapContext mapper (p, n, nl, s) = | |
22 | let (p2, s2) = (mapAdj mapper) n (p, s) in (p2, n, nl, s2) | |
23 | ||
24 | instance Graph EdgeMappedGraph where | |
25 | isEmpty g = null (labEdges g) | |
26 | labNodes (EdgeMappedGraph mapper orig) = labNodes orig | |
27 | noNodes (EdgeMappedGraph mapper orig) = noNodes orig | |
28 | nodeRange (EdgeMappedGraph mapper orig) = nodeRange orig | |
29 | labEdges (EdgeMappedGraph mapper orig) = concatMap (mapLEdge mapper) (labEdges orig) | |
30 | ||
31 | match n (EdgeMappedGraph mapper orig) = | |
32 | let | |
33 | (mCtx, g1) = match n orig | |
34 | mCtx2 = do | |
35 | ctx <- mCtx | |
36 | return (edgeMapContext mapper ctx) | |
37 | in (mCtx2, EdgeMappedGraph mapper g1) | |
38 | ||
39 | matchAny (EdgeMappedGraph mapper orig) = | |
40 | let (ctx, g1) = matchAny orig in | |
41 | (edgeMapContext mapper ctx, EdgeMappedGraph mapper g1) | |
42 | ||
43 | -- Graph construction: not supported. | |
44 | empty = undefined | |
45 | mkGraph nodes edges = undefined | |
46 | ||
47 | buildEdgeMappedGraph :: Graph gr => EdgeMapper b1 b2 -> gr a b1 -> gr a b2 | |
48 | buildEdgeMappedGraph mapper g = | |
49 | mkGraph (labNodes g) (concatMap (mapLEdge mapper) $ labEdges g) | |
50 | ||
51 | edgeFilterMapper :: (LEdge b -> Bool) -> EdgeMapper b b | |
52 | edgeFilterMapper ff = EdgeMapper | |
53 | (\n (p, s) -> (filter (\(el, pn) -> ff (pn, n, el)) p, | |
54 | filter (\(el, sn) -> ff ( n, sn, el)) s)) | |
55 | (\edge -> if ff edge then [edge] else []) | |
56 | ||
57 | -- Returns a wrapper (whose type does not support graph construction) instead | |
58 | -- of building a new graph of the original type. | |
59 | filterEdgesLite :: Graph gr => (LEdge b -> Bool) -> gr a b -> EdgeMappedGraph a b | |
60 | filterEdgesLite filterF graph = EdgeMappedGraph (edgeFilterMapper filterF) graph | |
61 | ||
62 | edgeBidirectorMapper :: (Bool -> b1 -> b2) -> EdgeMapper b1 b2 | |
63 | edgeBidirectorMapper flipF = EdgeMapper | |
64 | (\n (p, s) -> ( | |
65 | map (\(el, pn) -> (flipF False el, pn)) p ++ | |
66 | map (\(el, sn) -> (flipF True el, sn)) s, | |
67 | map (\(el, sn) -> (flipF False el, sn)) s ++ | |
68 | map (\(el, pn) -> (flipF True el, pn)) p)) | |
69 | (\(pn, sn, el) -> [(pn, sn, flipF False el), (sn, pn, flipF True el)]) | |
70 | ||
71 | bidirectEdgesLite :: Graph gr => (Bool -> b1 -> b2) -> gr a b1 -> EdgeMappedGraph a b2 | |
72 | bidirectEdgesLite flipF graph = EdgeMappedGraph (edgeBidirectorMapper flipF) graph | |
73 | ||
74 | buildBidirectedEdgeGraph :: Graph gr => (Bool -> b1 -> b2) -> gr a b1 -> gr a b2 | |
75 | buildBidirectedEdgeGraph flipF graph = buildEdgeMappedGraph (edgeBidirectorMapper flipF) graph |