diff --git a/Tools/StatePlot.hs b/Tools/StatePlot.hs --- a/Tools/StatePlot.hs +++ b/Tools/StatePlot.hs @@ -20,6 +20,7 @@ import Graphics.Rendering.Chart.Gtk import qualified Graphics.Rendering.Cairo as C import Data.Colour +import Data.Colour.SRGB import Data.Colour.Names @@ -50,20 +51,32 @@ data RenderConfiguration = RenderConf { barHeight :: Double, tickIntervalMs :: Double, + largeTickFreq :: Int, expireTimeMs :: Double, cmpTracks :: Event -> Event -> Ordering, - phantomColor :: Maybe String + phantomColor :: Maybe String, + fromTime :: Maybe LocalTime, + toTime :: Maybe LocalTime } +data TickSize = LargeTick | SmallTick + renderEvents :: RenderConfiguration -> [Event] -> Renderable () renderEvents conf es = Renderable {minsize = return (0,0), render = render'} where events = sortBy (comparing time) es - minTime = time $ head events - maxTime = time $ last events - time2ms t = diffToMillis t minTime - rangeMs = time2ms maxTime - ticks = takeWhile ( minInputTime; Just t -> t } + maxRenderTime = case toTime conf of { Nothing -> maxInputTime; Just t -> t } + time2ms t | t < minRenderTime = time2ms minRenderTime + | t > maxRenderTime = time2ms maxRenderTime + | otherwise = diffToMillis t minRenderTime + rangeMs = time2ms maxRenderTime + ticks = takeWhile (( if i`mod`largeTickFreq conf == 0 + then (LargeTick, fromIntegral i*tickIntervalMs conf) + else (SmallTick, fromIntegral i*tickIntervalMs conf)) [0..] tracks = sortBy (\as bs -> cmpTracks conf (head as) (head bs)) . groupBy ((==) `on` track) . sortBy (comparing track) $ events maybeM :: (Monad m) => (a -> m b) -> Maybe a -> m () @@ -73,10 +86,10 @@ bars track = execWriter . (`evalStateT` Nothing) . mapM_ step . prepare $ track where prepare t = (capStart t) ++ t ++ (capEnd t) - capEnd t = [Event maxTime undefined (End "")] + capEnd t = [Event maxInputTime undefined (End "")] capStart t = case (phantomColor conf, t) of - (_, Event _ _ (End c):_) | c /= "" -> [Event minTime undefined (Begin c)] - (Just c, Event _ _ (End _):_) -> [Event minTime undefined (Begin c)] + (_, Event _ _ (End c):_) | c /= "" -> [Event minInputTime undefined (Begin c)] + (Just c, Event _ _ (End _):_) -> [Event minInputTime undefined (Begin c)] _ -> [] step (Event t _ edge) = do @@ -86,40 +99,68 @@ else [ExpiredBar (time2ms t0) (time2ms t0 + expireTimeMs conf) (overrideEnd c0)]) put (case edge of { Begin c -> Just (t,c); End _ -> Nothing }) + readColour ('#':r1:r2:g1:g2:b1:b2:[]) = Just (sRGB24 r g b) + where + r = fromIntegral $ unhex r2 + 16*unhex r1 + g = fromIntegral $ unhex g2 + 16*unhex g1 + b = fromIntegral $ unhex b2 + 16*unhex b1 + unhex c | c >= '0' && c <= '9' = fromEnum c - fromEnum '0' + | c >= 'a' && c <= 'z' = fromEnum c - fromEnum 'a' + | c >= 'A' && c <= 'Z' = 10 + fromEnum c - fromEnum 'A' + readColour cs = readColourName cs + render' (w,h) = do let ms2x ms = 10 + ms / rangeMs * (w - 10) let time2x t = ms2x (time2ms t) let numTracks = length tracks - let yStep = (h-10) / fromIntegral (numTracks+1) + let yStep = (h-20) / fromIntegral (numTracks+1) let track2y i = fromIntegral (i+1) * yStep - (barHeight conf)/2 - let drawTick ms = do { + let drawTick (t, ms) = do { setLineStyle $ solidLine 1 (opaque black) - ; moveTo $ Point (ms2x ms) (h-10) - ; lineTo $ Point (ms2x ms) (h-5) + ; moveTo $ Point (ms2x ms) (h-20) + ; lineTo $ Point (ms2x ms) (h-case t of { LargeTick -> 13 ; SmallTick -> 17 }) ; c $ C.stroke } + + let fillRectAA (Point x1 y1) (Point x2 y2) = do { + c $ C.newPath + ; c $ C.moveTo x1 y1 + ; c $ C.lineTo x1 y2 + ; c $ C.lineTo x2 y2 + ; c $ C.lineTo x2 y1 + ; c $ C.closePath + ; c $ C.fill + } + let strokeLineAA (Point x1 y1) (Point x2 y2) = do { + c $ C.newPath + ; c $ C.moveTo x1 y1 + ; c $ C.lineTo x2 y2 + ; c $ C.stroke + } let drawBar i (Bar ms1 ms2 color) = do { setLineStyle $ solidLine 1 transparent - ; setFillStyle $ solidFillStyle $ opaque $ fromMaybe (error $ "unknown color: " ++ color) (readColourName color) - ; fillPath (rectPath $ Rect (Point (ms2x ms1) (track2y i - (barHeight conf)/2)) (Point (ms2x ms2) (track2y i + (barHeight conf)/2))) + ; setFillStyle $ solidFillStyle $ opaque $ fromMaybe (error $ "unknown color: " ++ color) (readColour color) + ; fillRectAA (Point (ms2x ms1) (track2y i - (barHeight conf)/2)) (Point (ms2x ms2) (track2y i + (barHeight conf)/2)) } drawBar i (ExpiredBar ms1 ms2 color) = do { - setLineStyle $ dashedLine 1 [3,3] (opaque $ fromMaybe (error $ "unknown color: " ++ color) (readColourName color)) - ; strokePath [Point (ms2x ms1) (track2y i), Point (ms2x ms2) (track2y i)] + setLineStyle $ dashedLine 1 [3,3] (opaque $ fromMaybe (error $ "unknown color: " ++ color) (readColour color)) + ; strokeLineAA (Point (ms2x ms1) (track2y i)) (Point (ms2x ms2) (track2y i)) ; setLineStyle $ solidLine 1 (opaque red) - ; strokePath [Point (ms2x ms2 - 5) (track2y i - 5), Point (ms2x ms2 + 5) (track2y i + 5)] - ; strokePath [Point (ms2x ms2 + 5) (track2y i - 5), Point (ms2x ms2 - 5) (track2y i + 5)] + ; strokeLineAA (Point (ms2x ms2 - 5) (track2y i - 5)) (Point (ms2x ms2 + 5) (track2y i + 5)) + ; strokeLineAA (Point (ms2x ms2 + 5) (track2y i - 5)) (Point (ms2x ms2 - 5) (track2y i + 5)) } let drawTrack (i, es) = mapM_ (drawBar i) (bars es) setFillStyle $ solidFillStyle (opaque white) fillPath $ rectPath $ Rect (Point 0 0) (Point w h) setLineStyle $ solidLine 1 (opaque black) - moveTo (Point 10 (h-10)) - lineTo (Point w (h-10)) + moveTo (Point 10 (h-20)) + lineTo (Point w (h-20)) c $ C.stroke - moveTo (Point 10 (h-10)) + moveTo (Point 10 (h-20)) lineTo (Point 10 0) c $ C.stroke + moveTo (Point 10 (h-3)) + c $ C.showText $ "Origin at " ++ show minRenderTime ++ ", 1 small tick = " ++ show (tickIntervalMs conf) ++ "ms" mapM_ drawTick ticks mapM_ drawTrack $ zip [0..] tracks return nullPickFn @@ -128,7 +169,8 @@ "splot - a tool for visualizing the lifecycle of many concurrent multi-stage processes. See http://www.haskell.org/haskellwiki/Splot", "Usage: splot [-if INFILE] [-o PNGFILE] [-w WIDTH] [-h HEIGHT] [-bh BARHEIGHT] ", " [-tf TIMEFORMAT] [-sort SORT] [-expire EXPIRE]", - " [-tickInterval TICKINTERVAL]", + " [-fromTime TIME] [-toTime TIME]", + " [-tickInterval TICKINTERVAL] [-largeTickFreq N]", " -if INFILE - filename from where to read the trace.", " If omitted or '-', read from stdin.", " -o PNGFILE - filename to which the output will be written in PNG format.", @@ -140,7 +182,8 @@ " fractional seconds supported via %OS - will parse 12.4039 or 12,4039", " Also, %^[+-][N]s will parse seconds since the epoch, for example ", " %^-3s are milliseconds since the epoch (N can only be 1 digit)", - " -tickInterval - ticks on the X axis will be this often (in millis).", + " -tickInterval - ticks on the X axis will be this often (in millis, default 1000).", + " -largeTickFreq N - every N'th tick will be larger than the others (default 10).", " -sort SORT - sort tracks by SORT, where: 'time' - sort by time of first event, ", " 'name' - sort by track name.", " -expire - expire activities after given time period (in millis) - for instance,", @@ -154,7 +197,7 @@ "2010-10-21 16:45:09,431 >foo green", "2010-10-21 16:45:09,541 >bar green", "2010-10-21 16:45:10,631 >foo yellow", - "2010-10-21 16:45:10,725 >foo red", + "2010-10-21 16:45:10,725 >foo #ff0000", "2010-10-21 16:45:10,930 >bar blue", "2010-10-21 16:45:11,322 return () let (w,h) = (read $ getArg "w" "640" args, read $ getArg "h" "480" args) let barHeight = read $ getArg "bh" "5" args - let tickIntervalMs = read $ getArg "tickInterval" "10" args + let tickIntervalMs = read $ getArg "tickInterval" "1000" args + let largeTickFreq = read $ getArg "largeTickFreq" "10" args let timeFormat = getArg "tf" "%Y-%m-%d %H:%M:%OS" args let parseTime s = fromMaybe (error $ "Invalid time: " ++ show s) . strptime (B.pack timeFormat) $ s + let fromTime = fst `fmap` (strptime timeFormat $ getArg "fromTime" "" args) + let toTime = fst `fmap` (strptime timeFormat $ getArg "toTime" "" args) let outPNG = getArg "o" "" args let inputFile = getArg "if" "-" args input <- if inputFile == "-" then B.getContents else B.readFile inputFile @@ -185,7 +231,7 @@ let cmpTracks = case getArg "sort" "time" args of { "time" -> comparing time ; "name" -> comparing track } let expireTimeMs = read $ getArg "expire" "Infinity" args let phantomColor = case getArg "phantom" "" args of { "" -> Nothing; c -> Just c } - let pic = renderEvents (RenderConf barHeight tickIntervalMs expireTimeMs cmpTracks phantomColor) events + let pic = renderEvents (RenderConf barHeight tickIntervalMs largeTickFreq expireTimeMs cmpTracks phantomColor fromTime toTime) events case outPNG of "" -> renderableToWindow pic w h f -> const () `fmap` renderableToPNGFile pic w h outPNG diff --git a/splot.cabal b/splot.cabal --- a/splot.cabal +++ b/splot.cabal @@ -1,5 +1,5 @@ Name: splot -Version: 0.1.16 +Version: 0.1.17 License: BSD3 License-file: LICENSE Copyright: Eugene Kirpichov, 2010 @@ -30,3 +30,4 @@ Build-Depends: cairo, bytestring, bytestring-lexing, strptime >= 0.1.7, time, containers, colour, haskell98, Chart, mtl Main-Is: Tools/StatePlot.hs + Ghc-Options: -O2 -rtsopts