Add support for generating dot renders of a (portion of) a resolver run.

4 files changed, 208 insertions, 4 deletions

diff --git a/tools/resolver-visualize/Main.hs b/tools/resolver-visualize/Main.hs
index d8596a60..17cff491 100755
--- a/tools/resolver-visualize/Main.hs
+++ b/tools/resolver-visualize/Main.hs
@@ -7,6 +7,7 @@ import qualified Control.Monad.State as State
 import Control.Monad.Trans(liftIO)
 import Data.ByteString.Char8 as ByteString(ByteString, empty, hGet, pack, unpack)
 import Data.List(intersperse)
+import Dot
 import Graphics.UI.Gtk
 import Graphics.UI.Gtk.Glade
 import Graphics.UI.Gtk.SourceView
@@ -25,6 +26,7 @@ import Resolver.Types
 import Resolver.Util
 import System.IO
 import System.Time
+import Text.Printf
 
 xmlFilename = "resolver-visualize.glade"
 
@@ -223,10 +225,13 @@ data Params =
       -- always loaded, but only this many are rendered).
       maxSteps :: Maybe Integer,
       -- | The first step to start rendering.
-      firstStep :: Maybe Integer
+      firstStep :: Maybe Integer,
+      -- | Where and whether to send dot output.
+      dotOutput :: Maybe String
     } deriving(Eq, Ord, Show)
 defaultParams = Params { maxSteps  = Nothing,
-                         firstStep = Nothing }
+                         firstStep = Nothing,
+                         dotOutput = Nothing }
 
 -- | Shared context for the visualizer.
 data VisualizeContext =
@@ -943,9 +948,99 @@ filterUserParams ("--max-steps":(n:args)) params = let params' = params { maxSte
                                                    filterUserParams args params'
 filterUserParams ("--first-step":(n:args)) params = let params' = params { firstStep = Just $ read n } in
                                                     filterUserParams args params'
+filterUserParams ("--dot-output":(fn:args)) params = let params' = params { dotOutput = Just $ fn } in
+                                                     filterUserParams args params'
 filterUserParams (arg:args) params = let (args', params') = filterUserParams args params in
                                      (arg:args', params')
 
+textProgress :: IORef Integer -> Integer -> Integer -> IO ()
+textProgress ref cur max =
+    do lastPercent <- readIORef ref
+       (if cur >= (max * (lastPercent + 10) `div` 100)
+        then do let newPercent = lastPercent + 10
+                print newPercent
+                writeIORef ref newPercent
+        else return ())
+
+makeTextProgress :: IO (Integer -> Integer -> IO ())
+makeTextProgress = do ref <- newIORef 0
+                      return $ textProgress ref
+
+inBounds :: Params -> Integer -> Bool
+inBounds params n = let first = maybe 0 id (firstStep params) in
+                    n >= first && maybe True (\max -> n < first + max) (maxSteps params)
+
+dotChoiceLabel :: LinkChoice -> String
+dotChoiceLabel lc@(LinkChoice c) = choiceText lc
+dotChoiceLabel Unknown           = ""
+
+dotStepNode :: Params -> ProcessingStep -> Node
+dotStepNode params step = node (name $ printf "step%d" (stepOrder step))
+                          ..= ("label", printf "Step: %d\nScore: %d\nTier: %s"
+                                          (stepOrder step)
+                                          (solScore $ stepSol step)
+                                          (show $ solTier $ stepSol step))
+
+-- Generate nodes for any successors that were not processed in the
+-- render.
+dotUnprocessedSuccs :: Params -> ProcessingStep -> [Node]
+dotUnprocessedSuccs params step = unprocessed ++ excluded
+    where unprocessed = [ node (name $ printf "step%dunproc%d" (stepOrder step) n)
+                                   ..= ("label", printf "Unprocessed\nScore: %d\nTier: %s"
+                                                   (solScore succSol)
+                                                   (show $ solTier succSol))
+                                   ..= ("style", "dashed")
+                          | ((Unprocessed { successorChoice    = succChoice,
+                                            successorSolution  = succSol }),
+                             n)
+                          <- zip (stepSuccessors step) ([0..] :: [Integer]) ]
+          excluded    = [ node (name $ printf "step%d" (stepOrder step))
+                                   ..= ("label", printf "%d nodes..." (stepBranchSize step))
+                                   ..= ("shape", "plaintext")
+                                   ..= ("image", "cloud.png")
+                          | (Successor { successorStep = step }) <- stepSuccessors step,
+                            not $ inBounds params (stepOrder step) ]
+
+dotEdges params step = processed ++ unprocessed
+    where processed   = [ edge (node (name $ printf "step%d" (stepOrder step)))
+                               (node (name $ printf "step%d" (stepOrder step')))
+                          ..= ("label", dotChoiceLabel succChoice)
+                          | Successor { successorStep   = step',
+                                        successorChoice = succChoice } <- stepSuccessors step ]
+          unprocessed = [ edge (node (name $ printf "step%d" (stepOrder step)))
+                               (node (name $ printf "step%dunproc%d" (stepOrder step) n))
+                          ..= ("label", dotChoiceLabel succChoice)
+                          | ((Unprocessed { successorChoice = succChoice }), n)
+                              <- zip (stepSuccessors step) ([0..] :: [Integer]) ]
+
+renderDot :: Params -> [ProcessingStep] -> Digraph
+renderDot params steps =
+    let droppedSteps   = maybe steps (\n -> genericDrop n steps) (firstStep params)
+        truncatedSteps = maybe steps (\n -> genericTake n steps) (maxSteps params) in
+    if null truncatedSteps
+    then error "No steps to render."
+    else let stepNodes          = map (dotStepNode params) truncatedSteps
+             unprocessed        = concat $ map (dotUnprocessedSuccs params) truncatedSteps
+             edges              = concat $ map (dotEdges params) truncatedSteps in
+         digraph (stepNodes ++ unprocessed) edges
+
+writeDotRun params steps outputFile =
+    do let dot = renderDot params steps
+       withFile outputFile WriteMode $ \h ->
+           hPutStrLn h (show dot)
+
+writeDotOutput params logFile outputFile =
+    -- TODO: show progress better.
+    do progress <- makeTextProgress
+       withFile logFile ReadMode $ \h ->
+           do log <- loadLogFile h logFile progress
+              (if null $ runs log
+               then return ()
+               else if (null (drop 1 $ runs log))
+                    then writeDotRun params (head $ runs log) outputFile
+                    else sequence_ [ writeDotRun params steps (printf "%s-%d" outputFile n)
+                                         | (steps, n) <- zip (runs log) ([1..] :: [Integer]) ])
+
 main :: IO ()
 main = do -- Gtk2Hs whines loudly if it gets loaded into a threaded
           -- runtime, but runhaskell always loads a threaded runtime,
@@ -961,7 +1056,10 @@ main = do -- Gtk2Hs whines loudly if it gets loaded into a threaded
             [] -> do (xml, ctx) <- runMain (newMainWindow params) mainLoopContext
                      mainWin <- xmlGetWidget xml castToWindow "main_window"
                      widgetShow (toWidget mainWin)
-            [filename] -> runMain (load params filename) mainLoopContext
+                     mainLoopRun mainLoop
+            [filename] ->
+                case params of
+                  Params { dotOutput = Just output } -> writeDotOutput params filename output
+                  _ -> runMain (load params filename) mainLoopContext >> mainLoopRun mainLoop
             otherwise -> error "Too many arguments; expected at most one (the log file to load)."
-          mainLoopRun mainLoop
 
diff --git a/tools/resolver-visualize/cloud.eps b/tools/resolver-visualize/cloud.eps
new file mode 100644
index 00000000..b587cef0
--- /dev/null
+++ b/tools/resolver-visualize/cloud.eps
@@ -0,0 +1,34 @@
+%!PS-Adobe-3.0 EPSF-3.0
+%%Creator: inkscape 0.46
+%%Pages: 1
+%%Orientation: Portrait
+%%BoundingBox: 159 515 234 573
+%%HiResBoundingBox: 159.55352 515.52896 233.81222 572.32121
+%%EndComments
+%%Page: 1 1
+0 842 translate
+0.8 -0.8 scale
+0 0 0 setrgbcolor
+[] 0 setdash
+1 setlinewidth
+0 setlinejoin
+0 setlinecap
+gsave [1 0 0 1 0 0] concat
+0 0 0 setrgbcolor
+[] 0 setdash
+1 setlinewidth
+0 setlinejoin
+0 setlinecap
+newpath
+212.85714 388.07646 moveto
+200.94701 377.82874 190.4092 365.89459 214.28571 355.93361 curveto
+215.32448 333.27085 226.62417 333.69513 242.85714 345.21932 curveto
+268.67569 332.70039 273.88125 346.71272 272.14286 358.07647 curveto
+299.35954 364.19733 296.06175 378.62448 275.71429 386.6479 curveto
+273.10635 422.45606 241.98302 401.66679 241.42858 395.21933 curveto
+236.05901 409.76535 211.09495 415.66279 212.85714 388.07646 curveto
+closepath
+stroke
+grestore
+showpage
+%%EOF
diff --git a/tools/resolver-visualize/cloud.png b/tools/resolver-visualize/cloud.png
new file mode 100644
index 00000000..f42d245e
--- /dev/null
+++ b/tools/resolver-visualize/cloud.png
diff --git a/tools/resolver-visualize/cloud.svg b/tools/resolver-visualize/cloud.svg
new file mode 100644
index 00000000..e12c8b9c
--- /dev/null
+++ b/tools/resolver-visualize/cloud.svg
@@ -0,0 +1,72 @@
+<?xml version="1.0" encoding="UTF-8" standalone="no"?>
+<!-- Created with Inkscape (http://www.inkscape.org/) -->
+<svg
+   xmlns:dc="http://purl.org/dc/elements/1.1/"
+   xmlns:cc="http://creativecommons.org/ns#"
+   xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+   xmlns:svg="http://www.w3.org/2000/svg"
+   xmlns="http://www.w3.org/2000/svg"
+   xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
+   xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
+   width="744.09448819"
+   height="1052.3622047"
+   id="svg2"
+   sodipodi:version="0.32"
+   inkscape:version="0.46"
+   sodipodi:docname="cloud.svg"
+   inkscape:output_extension="org.inkscape.output.svg.inkscape">
+  <defs
+     id="defs4">
+    <inkscape:perspective
+       sodipodi:type="inkscape:persp3d"
+       inkscape:vp_x="0 : 526.18109 : 1"
+       inkscape:vp_y="0 : 1000 : 0"
+       inkscape:vp_z="744.09448 : 526.18109 : 1"
+       inkscape:persp3d-origin="372.04724 : 350.78739 : 1"
+       id="perspective10" />
+  </defs>
+  <sodipodi:namedview
+     id="base"
+     pagecolor="#ffffff"
+     bordercolor="#666666"
+     borderopacity="1.0"
+     gridtolerance="10000"
+     guidetolerance="10"
+     objecttolerance="10"
+     inkscape:pageopacity="0.0"
+     inkscape:pageshadow="2"
+     inkscape:zoom="1.4"
+     inkscape:cx="382.14286"
+     inkscape:cy="611.42857"
+     inkscape:document-units="px"
+     inkscape:current-layer="layer1"
+     showgrid="false"
+     inkscape:window-width="1918"
+     inkscape:window-height="1148"
+     inkscape:window-x="0"
+     inkscape:window-y="25" />
+  <metadata
+     id="metadata7">
+    <rdf:RDF>
+      <cc:Work
+         rdf:about="">
+        <dc:format>image/svg+xml</dc:format>
+        <dc:type
+           rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
+      </cc:Work>
+    </rdf:RDF>
+  </metadata>
+  <g
+     inkscape:label="Layer 1"
+     inkscape:groupmode="layer"
+     id="layer1">
+    <path
+       style="fill:none;fill-rule:evenodd;stroke:#000000;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
+       d="M 212.85714,388.07646 C 200.94701,377.82874 190.4092,365.89459 214.28571,355.93361 C 215.32448,333.27085 226.62417,333.69513 242.85714,345.21932 C 268.67569,332.70039 273.88125,346.71272 272.14286,358.07647 C 299.35954,364.19733 296.06175,378.62448 275.71429,386.6479 C 273.10635,422.45606 241.98302,401.66679 241.42858,395.21933 C 236.05901,409.76535 211.09495,415.66279 212.85714,388.07646 z"
+       id="path2447"
+       sodipodi:nodetypes="ccccccc"
+       inkscape:export-filename="/tmp/cloud.png"
+       inkscape:export-xdpi="200.05524"
+       inkscape:export-ydpi="200.05524" />
+  </g>
+</svg>