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 |
fd0d2377 | 14 | import ProposalMatcher |
89b7fd0d MM |
15 | import PMDefaults |
16 | import PMInstanceGenerator | |
17 | import Evaluation | |
fd0d2377 | 18 | import MonadStuff |
89b7fd0d | 19 | import RandomizedMonad |
fd0d2377 MM |
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 | ||
05a6f0ed MM |
35 | showInstanceAsGraph :: PMInstance -> PMatching -> Gr String String |
36 | showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA) matchedPairs = | |
fd0d2377 MM |
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 | |
89b7fd0d MM |
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") |