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 expA fixA pnrA) (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 ++ "[" ++ show (pnrA ! 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) $
  52                                 show (prefA ! (i, j)) ++ ":" ++ show (expA ! (i, j)) ++ (if fixA ! (i, j) then "*" else ""))
  53         in mkGraph theNodes theEdges
  54
  55 goFile :: String -> IO ()
  56 goFile fname = do
  57         pid <- runCommand ("gnome-open " ++ fname)
  58         waitForProcess pid -- gnome-open exits immediately
  59         nop
  60
  61 createHandlePipe :: IO (Handle, Handle)
  62 createHandlePipe = do
  63         (rFd, wFd) <- createPipe
  64         rH <- fdToHandle rFd
  65         wH <- fdToHandle wFd
  66         return (rH, wH)
  67
  68 -- GHCi seems to crash if I call this on a "showInstanceAsGraph" result without
  69 -- having previously forced evaluation of the matching.
  70 goGraph :: (Show a, Show b, Graph gr) => gr a b -> IO ()
  71 goGraph theGraph =
  72         -- First generate graphviz code.
  73         let gvCode = graphviz' theGraph in do
  74         -- Then have `dot' convert it to postscript in a file.
  75         pt <- epochTime
  76         let fname = "graph-" ++ show pt ++ ".ps"
  77         (Just wH, _, _, dotPid) <- createProcess (proc "dot" ["-Tps", "-o", fname]) {std_in = CreatePipe}
  78         hPutStr wH gvCode
  79         hClose wH
  80         waitForProcess dotPid
  81         -- Then open the file.
  82         goFile fname
  83
  84 -- Both-ways list difference
  85 (/\) :: Eq a => [a] -> [a] -> ([a], [a])
  86 l1 /\ l2 = (l1 \\ l2, l2 \\ l1)
  87
  88 -- Evaluation!
  89 runEvaluation cfg nr np = do
  90         let inst = runRandom myGen $ randomInstance cfg nr np
  91         putStr (show inst ++ "\n")
  92         let PMatching m0 = doMatching cfg{loadTolerance = 0} inst
  93         putStr ("Matching with load tolerance 0:\n" ++ show m0 ++ "\n")
  94         let PMatching m1 = doMatching cfg{loadTolerance = 1} inst
  95         putStr ("Matching with load tolerance 1:\n" ++ show m1 ++ "\n")
  96         putStr ("Differences:\n" ++ show (m0 /\ m1) ++ "\n")
  97         let e0 = evaluateMatching cfg{loadTolerance = 0} inst (PMatching m0)
  98         putStr ("Evaluation of first matching:\n" ++ show e0 ++ "\n")
  99         let e1 = evaluateMatching cfg{loadTolerance = 1} inst (PMatching m1)
 100         putStr ("Evaluation of second matching:\n" ++ show e1 ++ "\n")
 101         putStr ("Evaluation differences:\n" ++
 102                 show (sortedDiffEvaluations e0 e1) ++ "\n")