Rename "desirability" to "preference" (much less awkward), with the

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

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