diff --git a/Tools/SPlotMain.hs b/Tools/SPlotMain.hs --- a/Tools/SPlotMain.hs +++ b/Tools/SPlotMain.hs @@ -12,7 +12,7 @@ import Data.Time import Data.Time.Parse -import Graphics.Rendering.Chart.Renderable(renderableToPNGFile) +import qualified Graphics.Rendering.Cairo as C import Data.Maybe(fromMaybe,isNothing) import Data.Ord(comparing) @@ -58,9 +58,10 @@ " Default: %Y-%m-%d %H:%M:%OS.", " -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).", - " -expire - expire activities after given time period (in millis) - for instance,", + " -expire N - expire activities after given time period (in millis) - for instance,", " to account that if an activity doesn't tell you it's finished for too long,", " then it probably was killed.", + " '-expire 0' means 'assume that all unclosed tracks have expired'.", " -phantom COL - 'phantom color' - if a track starts from a '<' event, it is assumed that", " the corresponding '>' event (not present in the log) was of color COL.", " Useful if you're drawing pieces of large logs.", @@ -123,6 +124,12 @@ addSeconds d t = utcToLocalTime utc (addUTCTime (fromRational $ toRational d) (localTimeToUTC utc t)) +cprogramToPNGFile :: CProgram -> Int -> Int -> FilePath -> IO () +cprogramToPNGFile prog w h file = do + C.withImageSurface C.FormatARGB32 w h $ \result -> do + C.renderWith result $ prog (fromIntegral w, fromIntegral h) + C.surfaceWriteToPNG result file + main = do args <- getArgs when (null args || args == ["--help"]) $ showHelp >> exitSuccess @@ -159,5 +166,4 @@ let colorMaps = [(S.pack scheme, map S.pack (words wheel)) | ("-colorscheme":scheme:wheel:_) <- tails args ] let pic = renderEvents (RenderConf barHeight tickIntervalMs largeTickFreq expireTimeMs phantomColor fromTime toTime forcedNumTracks colorMaps legendWidth) readEvents - renderableToPNGFile pic w h outPNG - + cprogramToPNGFile pic w h outPNG diff --git a/Tools/StatePlot.hs b/Tools/StatePlot.hs --- a/Tools/StatePlot.hs +++ b/Tools/StatePlot.hs @@ -1,21 +1,20 @@ {-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} -module Tools.StatePlot where +module Tools.StatePlot ( renderEvents + , BarHeight(..) + , CProgram + , parse + , RenderConfiguration(..) + ) where import Control.Monad.State.Strict as ST import qualified Data.Map as M import Data.List -import Data.Ord -import Data.Function -import Data.Maybe import Data.Time -import Data.Time.Parse import qualified Data.ByteString.Lazy.Char8 as B import qualified Data.ByteString.Char8 as S import Data.ByteString.Lex.Double -import Graphics.Rendering.Chart -import qualified Graphics.Rendering.Cairo.Internal as CI import qualified Graphics.Rendering.Cairo as C import Data.Colour import Data.Colour.SRGB @@ -85,13 +84,30 @@ data TickSize = LargeTick | SmallTick -newtype RenderState s a = RenderState { runRenderState :: StateT s CRender a } deriving (Monad, MonadState s) +newtype RenderState s a = RenderState { runRenderState :: StateT s C.Render a } deriving (Monad, MonadState s) -liftR :: CRender () -> RenderState s () +type CProgram = (Double, Double) -> C.Render () + +liftR :: C.Render () -> RenderState s () liftR r = RenderState $ lift r -renderEvents :: RenderConfiguration -> IO [Event] -> Renderable () -renderEvents conf readEs = Renderable {minsize = return (0,0), render = renderGlyphsAtFront (c $ liftIO readEs)} +colourChannel c = darken (recip (alphaChannel c)) (c `over` black) +setSourceColor c = let (RGB r g b) = toSRGB $ colourChannel c + in C.setSourceRGBA r g b (alphaChannel c) + +fillRect, strokeLine :: Double -> Double -> Double -> Double -> C.Render () +fillRect !x1 !y1 !x2 !y2 = C.rectangle x1 y1 (x2-x1) (y2-y1) >> C.fill +strokeLine !x1 !y1 !x2 !y2 = C.moveTo x1 y1 >> C.lineTo x2 y2 >> C.stroke + +lineStyle dashes c = do + C.setLineWidth 1 + C.setDash dashes 0 + C.setLineCap C.LineCapButt + C.setLineJoin C.LineJoinMiter + setSourceColor c + +renderEvents :: RenderConfiguration -> IO [Event] -> CProgram +renderEvents conf readEs = renderGlyphsAtFront $ liftIO readEs where {-# INLINE maybeM #-} maybeM :: (Monad m) => (a -> m b) -> Maybe a -> m () @@ -110,9 +126,13 @@ where flushTrack (track, (i, Nothing)) = return () flushTrack (track, (i, Just (mst0,c0))) = do - if (rangeMs - mst0 < expireTimeMs conf) - then withGlyph i (Bar mst0 rangeMs c0) - else withGlyph i (ExpiredBar mst0 (mst0 + expireTimeMs conf) c0) + if ((expireTimeMs conf > 0 && rangeMs - mst0 >= expireTimeMs conf) || + expireTimeMs conf == 0) + then withGlyph i (ExpiredBar mst0 (if expireTimeMs conf == 0 + then rangeMs + else (mst0 + expireTimeMs conf)) + c0) + else withGlyph i (Bar mst0 rangeMs c0) genGlyphs' ((e@(Event' mst track edge)):es) m !havePulses = do ((i,ms0), m') <- summon e mst m case (drawGlyphsNotBars, edge) of @@ -134,9 +154,9 @@ (False, _) -> do flip maybeM ms0 $ \(mst0,c0) -> do let overrideEnd c0 = case edge of { End c | not (S.null c) -> c; _ -> c0 } - if (mst - mst0 < expireTimeMs conf) - then withGlyph i (Bar mst0 mst (overrideEnd c0)) - else withGlyph i (ExpiredBar mst0 (mst0 + expireTimeMs conf) (overrideEnd c0)) + if (mst - mst0 >= expireTimeMs conf && expireTimeMs conf > 0) + then withGlyph i (ExpiredBar mst0 (mst0 + expireTimeMs conf) (overrideEnd c0)) + else withGlyph i (Bar mst0 mst (overrideEnd c0)) let m'' = M.insert track (i, case edge of { Begin c -> Just (mst,c); End _ -> Nothing }) m' genGlyphs' es m'' havePulses @@ -152,13 +172,12 @@ _ -> return () return ((i,Nothing), m') - renderGlyphsAtFront :: CRender [Event] -> (Double,Double) -> CRender (PickFn a) + renderGlyphsAtFront :: C.Render [Event] -> CProgram renderGlyphsAtFront readEs (w,h) = do - setFillStyle $ solidFillStyle (opaque white) - fillPath $ rectPath $ Rect (Point 0 0) (Point w h) + setSourceColor $ opaque white + fillRect 0 0 w h haveGlyphs <- render' readEs (w,h) False when haveGlyphs $ (render' readEs (w,h) True >> return ()) - return nullPickFn computeTimesTracks es = (a, b, M.size m) where @@ -171,7 +190,7 @@ override' x (Just y) = y override' x Nothing = x - render' :: CRender [Event] -> (Double,Double) -> Bool -> CRender Bool + render' :: C.Render [Event] -> (Double,Double) -> Bool -> C.Render Bool render' readEs (w,h) drawGlyphsNotBars = do es <- readEs @@ -193,99 +212,76 @@ let legendW = case legendWidth conf of { Just w -> fromIntegral w; Nothing -> 0 } let ms2x ms = legendW + 10 + ms / rangeMs * (w - 10 - legendW) - let yStep = case barHeight conf of { - BarHeightFixed _ -> (h-20) / fromIntegral (numTracks+1) - ; BarHeightFill -> (h-20) / fromIntegral numTracks - } - let track2y i = case barHeight conf of { - BarHeightFixed bh -> fromIntegral (i+1) * yStep - bh/2 - ; BarHeightFill -> fromIntegral (i+1) * yStep - yStep/2 - } - let drawTick (t, ms) = c $ do { - C.moveTo (ms2x ms + 1) (h-20) - ; C.lineTo (ms2x ms + 1) (h-case t of { LargeTick -> 13 ; SmallTick -> 17 }) - ; C.stroke - } - - let fillRect !x1 !y1 !x2 !y2 = C.rectangle x1 y1 (x2-x1) (y2-y1) >> C.fill - let strokeLine !x1 !y1 !x2 !y2 = C.moveTo x1 y1 >> C.lineTo x2 y2 >> C.stroke + let yStep = case barHeight conf of + BarHeightFixed _ -> (h-20) / fromIntegral (numTracks+1) + BarHeightFill -> (h-20) / fromIntegral numTracks + let track2y i = case barHeight conf of + BarHeightFixed bh -> fromIntegral (i+1) * yStep - bh/2 + BarHeightFill -> fromIntegral (i+1) * yStep - yStep/2 + + let drawTick (t, ms) = strokeLine (ms2x ms) (h-20) + (ms2x ms) (h-case t of { LargeTick -> 13 ; SmallTick -> 17 }) + let getColor :: S.ByteString -> RenderState ColorMap (RGB Double) - getColor c = do { + getColor c = do map <- ST.get - ; let (color, map') = computeColor map c - ; ST.put map' - ; return color - } + let (color, map') = computeColor map c + ST.put map' + return color let drawGlyph :: Int -> OutputGlyph -> RenderState ColorMap () drawGlyph !i (Bar !ms1 !ms2 !color) | drawGlyphsNotBars = return () - | otherwise = getColor color >>= \(RGB r g b) -> liftR $ c $ do { - C.setSourceRGB r g b - ; let y = track2y i - ; case barHeight conf of { - BarHeightFixed bh -> fillRect (ms2x ms1) (y - bh /2) (ms2x ms2) (y + bh /2) - ; BarHeightFill -> fillRect (ms2x ms1) (y - yStep/2) (ms2x ms2) (y + yStep/2) - } - ; return () - } + | otherwise = getColor color >>= \(RGB r g b) -> liftR $ do + C.setSourceRGB r g b + let y = track2y i + case barHeight conf of + BarHeightFixed bh -> fillRect (ms2x ms1) (y - bh /2) (ms2x ms2) (y + bh /2) + BarHeightFill -> fillRect (ms2x ms1) (y - yStep/2) (ms2x ms2) (y + yStep/2) + drawGlyph i (ExpiredBar ms1 ms2 color) | drawGlyphsNotBars = return () - | otherwise = getColor color >>= \(RGB r g b) -> liftR $ do { - setLineStyle $ dashedLine 1 [3,3] (opaque $ sRGB r g b) - ; let y = track2y i - ; c $ strokeLine (ms2x ms1) y (ms2x ms2) y - ; setLineStyle $ solidLine 1 (opaque red) - ; c $ strokeLine (ms2x ms2 - 5) (y - 5) (ms2x ms2 + 5) (y + 5) - ; c $ strokeLine (ms2x ms2 + 5) (y - 5) (ms2x ms2 - 5) (y + 5) - ; return () - } + | otherwise = getColor color >>= \(RGB r g b) -> liftR $ do + lineStyle [3,3] $ opaque $ sRGB r g b + let y = track2y i + strokeLine (ms2x ms1) y (ms2x ms2) y + lineStyle [] $ opaque red + strokeLine (ms2x ms2 - 5) (y - 5) (ms2x ms2 + 5) (y + 5) + strokeLine (ms2x ms2 + 5) (y - 5) (ms2x ms2 - 5) (y + 5) + drawGlyph i (OutPulse ms glyph color) | not drawGlyphsNotBars = return () - | otherwise = getColor color >>= \(RGB r g b) -> liftR $ case glyph of { - GlyphText text -> do { - setLineStyle $ solidLine 1 (opaque $ sRGB r g b) - ; let y = track2y i - ; moveTo (Point (ms2x ms) y) - ; c $ C.showText (S.unpack text) - ; return () - } - } + | otherwise = getColor color >>= \(RGB r g b) -> liftR $ case glyph of + GlyphText text -> do + lineStyle [] $ opaque $ sRGB r g b + let y = track2y i + C.moveTo (ms2x ms) y + C.showText (S.unpack text) let drawLegendItem :: Int -> S.ByteString -> RenderState ColorMap () - drawLegendItem !i !s = liftR $ case legendWidth conf of { + drawLegendItem !i !s = liftR $ case legendWidth conf of Nothing -> return () - ; Just w -> do { - setLineStyle $ solidLine 1 (opaque black) - ; let y = track2y i - ; C.TextExtents xbear ybear tw th _ _ <- c $ C.textExtents (S.unpack s) - ; moveTo (Point (fromIntegral w - tw - xbear - 5) (y - th/2 - ybear)) - ; c $ C.showText (S.unpack s) - } - } + Just w -> do + lineStyle [] $ opaque black + let y = track2y i + C.TextExtents xbear ybear tw th _ _ <- C.textExtents (S.unpack s) + C.moveTo (fromIntegral w - tw - xbear - 5) (y - th/2 - ybear) + C.showText (S.unpack s) when (not drawGlyphsNotBars) $ do - c $ C.setAntialias C.AntialiasNone - setLineStyle $ solidLine 1 (opaque black) - - -- Until a bug in Chart is resolved: http://hackage.haskell.org/packages/archive/Chart/0.13.1/doc/html/src/Graphics-Rendering-Chart-Types.html - -- setLineStyle for a solid line doesn't clear dashes because it doesn't call setDash if line_dashes_ ls is [] (???) - c $ C.setDash [] 0 + C.setAntialias C.AntialiasNone + lineStyle [] $ opaque black - moveTo (Point (legendW+10) (h-20)) - lineTo (Point w (h-20)) - c $ C.stroke - moveTo (Point (legendW+10) (h-20)) - lineTo (Point (legendW+10) 0) - c $ C.stroke + strokeLine (legendW+10) (h-20) w (h-20) + strokeLine (legendW+10) (h-20) (legendW+10) 0 mapM_ drawTick ticks - moveTo (Point (legendW+10) (h-3)) - c $ C.setAntialias C.AntialiasGray - c $ C.setFontSize 12 - c $ C.showText $ "Origin at " ++ show minRenderLocalTime ++ ", 1 small tick = " ++ show (tickIntervalMs conf) ++ "ms" + C.moveTo (legendW+10) (h-3) + C.setAntialias C.AntialiasGray + C.setFontSize 12 + C.showText $ "Origin at " ++ show minRenderLocalTime ++ ", 1 small tick = " ++ show (tickIntervalMs conf) ++ "ms" - c $ C.setAntialias C.AntialiasSubpixel + C.setAntialias C.AntialiasSubpixel let colorMap = prepareColorMap (colorWheels conf) evalStateT (runRenderState $ genGlyphs time2ms rangeMs es drawGlyphsNotBars drawGlyph drawLegendItem) colorMap diff --git a/splot.cabal b/splot.cabal --- a/splot.cabal +++ b/splot.cabal @@ -1,5 +1,5 @@ Name: splot -Version: 0.3.9 +Version: 0.3.11 License: BSD3 License-file: LICENSE Copyright: Eugene Kirpichov, 2010 @@ -28,7 +28,7 @@ Build-Depends: base < 3 Build-Depends: cairo, bytestring, bytestring-lexing, strptime >= 0.1.7, time, - containers, colour, Chart, mtl, HUnit, template-haskell, vcs-revision + containers, colour, mtl, HUnit, template-haskell, vcs-revision Other-Modules: Tools.ColorMap Tools.SPlotTest Tools.SPlotTest Tools.StatePlot Main-Is: Tools/SPlotMain.hs Ghc-Options: -O2 -rtsopts