program/TestUtils.hs

   1 module TestUtils where
   2 import Control.Concurrent
   3 import Data.Array.IArray
   4 import Data.Graph.Inductive.Graph
   5 import Data.Graph.Inductive.Graphviz
   6 import Data.Graph.Inductive.Tree
   7 import Data.List
   8 import System.IO
   9 import System.Random
  10 import System.Posix.IO
  11 import System.Posix.Time
  12 import System.Process
  13 import PMInstance
  14 import ProposalMatcher
  15 import PMDefaults
  16 import PMInstanceGenerator
  17 import Evaluation
  18 import MonadStuff
  19 import RandomizedMonad
  20
  21 -- This module has stuff that is helpful for testing but isn't itself an example.
  22
  23 -- A fixed-seeded random number generator for reproducible experimentation.
  24 myGen = read "314159265 1" :: StdGen
  25
  26 -- Visualization stuff.
  27 data REdgeF = REdgeF Int Int Int Wt
  28 instance Show REdgeF where
  29         show (REdgeF idx cap flow cost) = "#" ++ (show idx) ++ ": "
  30                 ++ (show flow) ++ " of " ++ (show cap) ++ " @ " ++ (show cost)
  31 flowAnnotate g fa =
  32         mkGraph (labNodes g) (map (\(n1, n2, REdge i ca co) ->
  33                 (n1, n2, REdgeF i ca (fa ! i) co)) $ labEdges g) :: Gr () REdgeF
  34
  35 showInstanceAsGraph :: PMInstance -> PMatching -> Gr String String
  36 showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA) matchedPairs =
  37         let
  38                 rvrNode i = i
  39                 propNode j = numRvrs + j
  40                 numNodes = numRvrs + numProps
  41                 theNodes = map (\i -> (rvrNode i, "R#" ++ show i ++
  42                                 " (RLoad " ++ show (rloadA ! i) ++ ")")) [0..numRvrs-1] ++
  43                         map (\j -> (propNode j, "P#" ++ show j)) [0..numProps-1]
  44                 parenthesizeIf False s = s
  45                 parenthesizeIf True s = "(" ++ s ++ ")"
  46                 theEdges = do
  47                         i <- [0..numRvrs-1]
  48                         j <- [0..numProps-1]
  49                         return (rvrNode i, propNode j,
  50                                 parenthesizeIf (elem (i, j) matchedPairs) $ show (prefA ! (i, j)))
  51         in mkGraph theNodes theEdges
  52
  53 goFile :: String -> IO ()
  54 goFile fname = do
  55         pid <- runCommand ("gnome-open " ++ fname)
  56         waitForProcess pid -- gnome-open exits immediately
  57         nop
  58
  59 createHandlePipe :: IO (Handle, Handle)
  60 createHandlePipe = do
  61         (rFd, wFd) <- createPipe
  62         rH <- fdToHandle rFd
  63         wH <- fdToHandle wFd
  64         return (rH, wH)
  65
  66 -- GHCi seems to crash if I call this on a "showInstanceAsGraph" result without
  67 -- having previously forced evaluation of the matching.
  68 goGraph :: (Show a, Show b, Graph gr) => gr a b -> IO ()
  69 goGraph theGraph =
  70         -- First generate graphviz code.
  71         let gvCode = graphviz' theGraph in do
  72         -- Then have `dot' convert it to postscript in a file.
  73         (rH, wH) <- createHandlePipe
  74         pt <- epochTime
  75         let fname = "graph-" ++ show pt ++ ".ps"
  76         dotPid <- runProcess "dot" ["-Tps", "-o", fname]
  77                 Nothing Nothing (Just rH) Nothing Nothing
  78         forkIO (do
  79                 hPutStr wH gvCode
  80                 hClose wH)
  81         waitForProcess dotPid
  82         -- Then open the file.
  83         goFile fname
  84
  85 -- Both-ways list difference
  86 (/\) :: Eq a => [a] -> [a] -> ([a], [a])
  87 l1 /\ l2 = (l1 \\ l2, l2 \\ l1)
  88
  89 -- Evaluation!
  90 runEvaluation nr np = do
  91         let inst = runRandom myGen $ randomInstance nr np
  92         putStr (show inst ++ "\n")
  93         let m0 = doMatching pmDefaults{loadTolerance = 0} inst
  94         putStr ("Matching with load tolerance 0:\n" ++ show m0 ++ "\n")
  95         let m1 = doMatching pmDefaults{loadTolerance = 1} inst
  96         putStr ("Matching with load tolerance 1:\n" ++ show m1 ++ "\n")
  97         putStr ("Differences:\n" ++ show (m0 /\ m1) ++ "\n")
  98         let e0 = evaluateMatching pmDefaults{loadTolerance = 0} inst m0
  99         putStr ("Evaluation of first matching:\n" ++ show e0 ++ "\n")
 100         let e1 = evaluateMatching pmDefaults{loadTolerance = 1} inst m1
 101         putStr ("Evaluation of second matching:\n" ++ show e1 ++ "\n")
 102         putStr ("Evaluation differences:\n" ++
 103                 show (sortedDiffEvaluations e0 e1) ++ "\n")