Commit | Line | Data |
---|---|---|
fd0d2377 MM |
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 | |
89b7fd0d | 7 | import Data.List |
fd0d2377 MM |
8 | import System.IO |
9 | import System.Random | |
10 | import System.Posix.IO | |
11 | import System.Posix.Time | |
12 | import System.Process | |
05a6f0ed | 13 | import PMInstance |
bc14b3b3 | 14 | import PMConfig |
fd0d2377 | 15 | import ProposalMatcher |
89b7fd0d MM |
16 | import PMDefaults |
17 | import PMInstanceGenerator | |
18 | import Evaluation | |
fd0d2377 | 19 | import MonadStuff |
89b7fd0d | 20 | import RandomizedMonad |
fd0d2377 MM |
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 | ||
05a6f0ed MM |
36 | showInstanceAsGraph :: PMInstance -> PMatching -> Gr String String |
37 | showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA) matchedPairs = | |
fd0d2377 MM |
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 | |
89b7fd0d MM |
85 | |
86 | -- Both-ways list difference | |
87 | (/\) :: Eq a => [a] -> [a] -> ([a], [a]) | |
88 | l1 /\ l2 = (l1 \\ l2, l2 \\ l1) | |
89 | ||
90 | -- Evaluation! | |
8723ed6a MM |
91 | runEvaluation cfg nr np = do |
92 | let inst = runRandom myGen $ randomInstance cfg nr np | |
89b7fd0d | 93 | putStr (show inst ++ "\n") |
8723ed6a | 94 | let m0 = doMatching cfg{loadTolerance = 0} inst |
89b7fd0d | 95 | putStr ("Matching with load tolerance 0:\n" ++ show m0 ++ "\n") |
8723ed6a | 96 | let m1 = doMatching cfg{loadTolerance = 1} inst |
89b7fd0d MM |
97 | putStr ("Matching with load tolerance 1:\n" ++ show m1 ++ "\n") |
98 | putStr ("Differences:\n" ++ show (m0 /\ m1) ++ "\n") | |
8723ed6a | 99 | let e0 = evaluateMatching cfg{loadTolerance = 0} inst m0 |
89b7fd0d | 100 | putStr ("Evaluation of first matching:\n" ++ show e0 ++ "\n") |
8723ed6a | 101 | let e1 = evaluateMatching cfg{loadTolerance = 1} inst m1 |
89b7fd0d MM |
102 | putStr ("Evaluation of second matching:\n" ++ show e1 ++ "\n") |
103 | putStr ("Evaluation differences:\n" ++ | |
104 | show (sortedDiffEvaluations e0 e1) ++ "\n") |