splot 0.3.9 → 0.3.11
raw patch · 3 files changed
+104/−102 lines, 3 filesdep −Chart
Dependencies removed: Chart
Files
- Tools/SPlotMain.hs +10/−4
- Tools/StatePlot.hs +92/−96
- splot.cabal +2/−2
Tools/SPlotMain.hs view
@@ -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
Tools/StatePlot.hs view
@@ -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
splot.cabal view
@@ -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