Rewrite Bellman-Ford and min-cost flow, especially to stop the latter from crashing.

[match/match.git] / program / GraphStuff.hs.old

diff --git a/program/GraphStuff.hs.old b/program/GraphStuff.hs.old
new file mode 100644 (file)
index 0000000..341090b
--- /dev/null
+++ b/program/GraphStuff.hs.old
@@ -0,0 +1,75 @@
+-- I wrote this to help with NaiveMinCostFlow but abandoned it.  Wrapping is
+-- more trouble than it's worth, and NaiveMinCostFlow needs access to its ST
+-- monad in the edge-filtering test, which would have required more mess here.
+
+module GraphStuff where
+import Data.Graph.Inductive.Graph
+
+data EdgeMapper b1 b2 = EdgeMapper {
+       -- Map the predecessor and successor edges of the given node for a context.
+       mapAdj :: Node -> (Adj b1, Adj b1) -> (Adj b2, Adj b2),
+       -- For labEdges.  Should be consistent with the above two!!!
+       mapLEdge :: LEdge b1 -> [LEdge b2]
+}
+
+data EdgeMappedGraph a b = forall gr b1. Graph gr => EdgeMappedGraph {
+       emgMapper :: EdgeMapper b1 b,
+       emgOrig   :: gr a b1
+}
+
+edgeMapContext :: EdgeMapper b1 b2 -> Context a b1 -> Context a b2
+edgeMapContext mapper (p, n, nl, s) =
+       let (p2, s2) = (mapAdj mapper) n (p, s) in (p2, n, nl, s2)
+
+instance Graph EdgeMappedGraph where
+       isEmpty g = null (labEdges g)
+       labNodes (EdgeMappedGraph mapper orig) = labNodes orig
+       noNodes (EdgeMappedGraph mapper orig) = noNodes orig
+       nodeRange (EdgeMappedGraph mapper orig) = nodeRange orig
+       labEdges (EdgeMappedGraph mapper orig) = concatMap (mapLEdge mapper) (labEdges orig)
+       
+       match n (EdgeMappedGraph mapper orig) =
+               let
+                       (mCtx, g1) = match n orig
+                       mCtx2 = do
+                               ctx <- mCtx
+                               return (edgeMapContext mapper ctx)
+               in (mCtx2, EdgeMappedGraph mapper g1)
+       
+       matchAny (EdgeMappedGraph mapper orig) =
+               let (ctx, g1) = matchAny orig in
+               (edgeMapContext mapper ctx, EdgeMappedGraph mapper g1)
+       
+       -- Graph construction: not supported.
+       empty = undefined
+       mkGraph nodes edges = undefined
+
+buildEdgeMappedGraph :: Graph gr => EdgeMapper b1 b2 -> gr a b1 -> gr a b2
+buildEdgeMappedGraph mapper g =
+       mkGraph (labNodes g) (concatMap (mapLEdge mapper) $ labEdges g)
+
+edgeFilterMapper :: (LEdge b -> Bool) -> EdgeMapper b b
+edgeFilterMapper ff = EdgeMapper
+       (\n (p, s) -> (filter (\(el, pn) -> ff (pn,  n, el)) p,
+                      filter (\(el, sn) -> ff ( n, sn, el)) s))
+       (\edge -> if ff edge then [edge] else [])
+
+-- Returns a wrapper (whose type does not support graph construction) instead
+-- of building a new graph of the original type.
+filterEdgesLite :: Graph gr => (LEdge b -> Bool) -> gr a b -> EdgeMappedGraph a b
+filterEdgesLite filterF graph = EdgeMappedGraph (edgeFilterMapper filterF) graph
+
+edgeBidirectorMapper :: (Bool -> b1 -> b2) -> EdgeMapper b1 b2
+edgeBidirectorMapper flipF = EdgeMapper
+       (\n (p, s) -> (
+               map (\(el, pn) -> (flipF False el, pn)) p ++
+                       map (\(el, sn) -> (flipF True el, sn)) s,
+               map (\(el, sn) -> (flipF False el, sn)) s ++
+                       map (\(el, pn) -> (flipF True el, pn)) p))
+       (\(pn, sn, el) -> [(pn, sn, flipF False el), (sn, pn, flipF True el)])
+
+bidirectEdgesLite :: Graph gr => (Bool -> b1 -> b2) -> gr a b1 -> EdgeMappedGraph a b2
+bidirectEdgesLite flipF graph = EdgeMappedGraph (edgeBidirectorMapper flipF) graph
+
+buildBidirectedEdgeGraph :: Graph gr => (Bool -> b1 -> b2) -> gr a b1 -> gr a b2
+buildBidirectedEdgeGraph flipF graph = buildEdgeMappedGraph (edgeBidirectorMapper flipF) graph