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