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