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) (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)) ++ ":" ++ show (expA ! (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         pt <- epochTime
  75         let fname = "graph-" ++ show pt ++ ".ps"
  76         (Just wH, _, _, dotPid) <- createProcess (proc "dot" ["-Tps", "-o", fname]) {std_in = CreatePipe}
  77         hPutStr wH gvCode
  78         hClose wH
  79         waitForProcess dotPid
  80         -- Then open the file.
  81         goFile fname
  82
  83 -- Both-ways list difference
  84 (/\) :: Eq a => [a] -> [a] -> ([a], [a])
  85 l1 /\ l2 = (l1 \\ l2, l2 \\ l1)
  86
  87 -- Evaluation!
  88 runEvaluation cfg nr np = do
  89         let inst = runRandom myGen $ randomInstance cfg nr np
  90         putStr (show inst ++ "\n")
  91         let PMatching m0 = doMatching cfg{loadTolerance = 0} inst
  92         putStr ("Matching with load tolerance 0:\n" ++ show m0 ++ "\n")
  93         let PMatching m1 = doMatching cfg{loadTolerance = 1} inst
  94         putStr ("Matching with load tolerance 1:\n" ++ show m1 ++ "\n")
  95         putStr ("Differences:\n" ++ show (m0 /\ m1) ++ "\n")
  96         let e0 = evaluateMatching cfg{loadTolerance = 0} inst (PMatching m0)
  97         putStr ("Evaluation of first matching:\n" ++ show e0 ++ "\n")
  98         let e1 = evaluateMatching cfg{loadTolerance = 1} inst (PMatching m1)
  99         putStr ("Evaluation of second matching:\n" ++ show e1 ++ "\n")
 100         putStr ("Evaluation differences:\n" ++
 101                 show (sortedDiffEvaluations e0 e1) ++ "\n")