Make PMatching a newtype for clarity.

[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 Data.List
import System.IO
import System.Random
import System.Posix.IO
import System.Posix.Time
import System.Process
import PMInstance
import PMConfig
import ProposalMatcher
import PMDefaults
import PMInstanceGenerator
import Evaluation
import MonadStuff
import RandomizedMonad

-- 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) (PMatching 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

-- Both-ways list difference
(/\) :: Eq a => [a] -> [a] -> ([a], [a])
l1 /\ l2 = (l1 \\ l2, l2 \\ l1)

-- Evaluation!
runEvaluation cfg nr np = do
	let inst = runRandom myGen $ randomInstance cfg nr np
	putStr (show inst ++ "\n")
	let PMatching m0 = doMatching cfg{loadTolerance = 0} inst
	putStr ("Matching with load tolerance 0:\n" ++ show m0 ++ "\n")
	let PMatching m1 = doMatching cfg{loadTolerance = 1} inst
	putStr ("Matching with load tolerance 1:\n" ++ show m1 ++ "\n")
	putStr ("Differences:\n" ++ show (m0 /\ m1) ++ "\n")
	let e0 = evaluateMatching cfg{loadTolerance = 0} inst (PMatching m0)
	putStr ("Evaluation of first matching:\n" ++ show e0 ++ "\n")
	let e1 = evaluateMatching cfg{loadTolerance = 1} inst (PMatching m1)
	putStr ("Evaluation of second matching:\n" ++ show e1 ++ "\n")
	putStr ("Evaluation differences:\n" ++
		show (sortedDiffEvaluations e0 e1) ++ "\n")