Rename Instance -> PMInstance and introduce PMatching type.

[match/match.git] / program / TestUtils.hs

module TestUtils where
import Control.Concurrent
import Data.Array.IArray
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Graphviz
import Data.Graph.Inductive.Tree
import System.IO
import System.Random
import System.Posix.IO
import System.Posix.Time
import System.Process
import PMInstance
import ProposalMatcher
import MonadStuff

-- This module has stuff that is helpful for testing but isn't itself an example.

-- A fixed-seeded random number generator for reproducible experimentation.
myGen = read "314159265 1" :: StdGen

-- Visualization stuff.
data REdgeF = REdgeF Int Int Int Wt
instance Show REdgeF where
	show (REdgeF idx cap flow cost) = "#" ++ (show idx) ++ ": "
		++ (show flow) ++ " of " ++ (show cap) ++ " @ " ++ (show cost)
flowAnnotate g fa =
	mkGraph (labNodes g) (map (\(n1, n2, REdge i ca co) ->
		(n1, n2, REdgeF i ca (fa ! i) co)) $ labEdges g) :: Gr () REdgeF

showInstanceAsGraph :: PMInstance -> PMatching -> Gr String String
showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA) matchedPairs =
	let
		rvrNode i = i
		propNode j = numRvrs + j
		numNodes = numRvrs + numProps
		theNodes = map (\i -> (rvrNode i, "R#" ++ show i ++
				" (RLoad " ++ show (rloadA ! i) ++ ")")) [0..numRvrs-1] ++
			map (\j -> (propNode j, "P#" ++ show j)) [0..numProps-1]
		parenthesizeIf False s = s
		parenthesizeIf True s = "(" ++ s ++ ")"
		theEdges = do
			i <- [0..numRvrs-1]
			j <- [0..numProps-1]
			return (rvrNode i, propNode j,
				parenthesizeIf (elem (i, j) matchedPairs) $ show (prefA ! (i, j)))
	in mkGraph theNodes theEdges

goFile :: String -> IO ()
goFile fname = do
	pid <- runCommand ("gnome-open " ++ fname)
	waitForProcess pid -- gnome-open exits immediately
	nop

createHandlePipe :: IO (Handle, Handle)
createHandlePipe = do
	(rFd, wFd) <- createPipe
	rH <- fdToHandle rFd
	wH <- fdToHandle wFd
	return (rH, wH)

-- GHCi seems to crash if I call this on a "showInstanceAsGraph" result without
-- having previously forced evaluation of the matching.
goGraph :: (Show a, Show b, Graph gr) => gr a b -> IO ()
goGraph theGraph =
	-- First generate graphviz code.
	let gvCode = graphviz' theGraph in do
	-- Then have `dot' convert it to postscript in a file.
	(rH, wH) <- createHandlePipe
	pt <- epochTime
	let fname = "graph-" ++ show pt ++ ".ps"
	dotPid <- runProcess "dot" ["-Tps", "-o", fname]
		Nothing Nothing (Just rH) Nothing Nothing
	forkIO (do
		hPutStr wH gvCode
		hClose wH)
	waitForProcess dotPid
	-- Then open the file.
	goFile fname