| 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 System.IO |
| 8 | import System.Random |
| 9 | import System.Posix.IO |
| 10 | import System.Posix.Time |
| 11 | import System.Process |
| 12 | import PMInstance |
| 13 | import ProposalMatcher |
| 14 | import MonadStuff |
| 15 | |
| 16 | -- This module has stuff that is helpful for testing but isn't itself an example. |
| 17 | |
| 18 | -- A fixed-seeded random number generator for reproducible experimentation. |
| 19 | myGen = read "314159265 1" :: StdGen |
| 20 | |
| 21 | -- Visualization stuff. |
| 22 | data REdgeF = REdgeF Int Int Int Wt |
| 23 | instance Show REdgeF where |
| 24 | show (REdgeF idx cap flow cost) = "#" ++ (show idx) ++ ": " |
| 25 | ++ (show flow) ++ " of " ++ (show cap) ++ " @ " ++ (show cost) |
| 26 | flowAnnotate g fa = |
| 27 | mkGraph (labNodes g) (map (\(n1, n2, REdge i ca co) -> |
| 28 | (n1, n2, REdgeF i ca (fa ! i) co)) $ labEdges g) :: Gr () REdgeF |
| 29 | |
| 30 | showInstanceAsGraph :: PMInstance -> PMatching -> Gr String String |
| 31 | showInstanceAsGraph (PMInstance numRvrs numProps rloadA prefA) matchedPairs = |
| 32 | let |
| 33 | rvrNode i = i |
| 34 | propNode j = numRvrs + j |
| 35 | numNodes = numRvrs + numProps |
| 36 | theNodes = map (\i -> (rvrNode i, "R#" ++ show i ++ |
| 37 | " (RLoad " ++ show (rloadA ! i) ++ ")")) [0..numRvrs-1] ++ |
| 38 | map (\j -> (propNode j, "P#" ++ show j)) [0..numProps-1] |
| 39 | parenthesizeIf False s = s |
| 40 | parenthesizeIf True s = "(" ++ s ++ ")" |
| 41 | theEdges = do |
| 42 | i <- [0..numRvrs-1] |
| 43 | j <- [0..numProps-1] |
| 44 | return (rvrNode i, propNode j, |
| 45 | parenthesizeIf (elem (i, j) matchedPairs) $ show (prefA ! (i, j))) |
| 46 | in mkGraph theNodes theEdges |
| 47 | |
| 48 | goFile :: String -> IO () |
| 49 | goFile fname = do |
| 50 | pid <- runCommand ("gnome-open " ++ fname) |
| 51 | waitForProcess pid -- gnome-open exits immediately |
| 52 | nop |
| 53 | |
| 54 | createHandlePipe :: IO (Handle, Handle) |
| 55 | createHandlePipe = do |
| 56 | (rFd, wFd) <- createPipe |
| 57 | rH <- fdToHandle rFd |
| 58 | wH <- fdToHandle wFd |
| 59 | return (rH, wH) |
| 60 | |
| 61 | -- GHCi seems to crash if I call this on a "showInstanceAsGraph" result without |
| 62 | -- having previously forced evaluation of the matching. |
| 63 | goGraph :: (Show a, Show b, Graph gr) => gr a b -> IO () |
| 64 | goGraph theGraph = |
| 65 | -- First generate graphviz code. |
| 66 | let gvCode = graphviz' theGraph in do |
| 67 | -- Then have `dot' convert it to postscript in a file. |
| 68 | (rH, wH) <- createHandlePipe |
| 69 | pt <- epochTime |
| 70 | let fname = "graph-" ++ show pt ++ ".ps" |
| 71 | dotPid <- runProcess "dot" ["-Tps", "-o", fname] |
| 72 | Nothing Nothing (Just rH) Nothing Nothing |
| 73 | forkIO (do |
| 74 | hPutStr wH gvCode |
| 75 | hClose wH) |
| 76 | waitForProcess dotPid |
| 77 | -- Then open the file. |
| 78 | goFile fname |