| 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") |