program/GraphStuff.hs.old

   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