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