splot 0.1.5 → 0.1.6
raw patch · 2 files changed
+36/−19 lines, 2 files
Files
- Tools/StatePlot.hs +35/−18
- splot.cabal +1/−1
Tools/StatePlot.hs view
@@ -22,6 +22,7 @@ import Data.Colour import Data.Colour.Names + data Event = Event {time :: LocalTime, track :: String, edge :: Edge} deriving (Show) data Edge = Begin { color :: String } | End deriving (Show) @@ -45,35 +46,48 @@ diffToMillis t2 t1 = fromIntegral (truncate (1000000*d)) / 1000 where d = diffUTCTime (localTimeToUTC utc t2) (localTimeToUTC utc t1) -renderEvents :: Double -> Double -> Double -> [Event] -> (Event -> Event -> Ordering) -> Renderable ()-renderEvents bandHeight ticksIntervalMs expireTimeMs es cmpTracks = Renderable {minsize = return (0,0), render = render'}+data TrackState = Phantom String | Active LocalTime String | Inactive deriving (Show)++data RenderConfiguration = RenderConf {+ barHeight :: Double,+ tickIntervalMs :: Double,+ expireTimeMs :: Double,+ cmpTracks :: Event -> Event -> Ordering,+ phantomColor :: Maybe String+ }++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 (<rangeMs) $ iterate (+ticksIntervalMs) 0- tracks = sortBy (\as bs -> cmpTracks (head as) (head bs)) . groupBy ((==) `on` track) . sortBy (comparing track) $ events+ ticks = takeWhile (<rangeMs) $ iterate (+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 ()- maybeM f Nothing = return ()- maybeM f (Just x) = f x >> return ()+ initial = case phantomColor conf of { Nothing -> Inactive; Just c -> Phantom c } - bars track = execWriter . (`evalStateT` Nothing) . mapM_ step $ track++[Event maxTime undefined End]+ bars track = execWriter . (`evalStateT` initial) . mapM_ step $ track++[Event maxTime undefined End] where step (Event t _ edge) = do- get >>= maybeM (\(t0,c0) -> tell $ if (time2ms t - time2ms t0 < expireTimeMs) - then [Bar (time2ms t0) (time2ms t) c0]- else [ExpiredBar (time2ms t0) (time2ms t0 + expireTimeMs) c0])- put (case edge of { Begin c -> Just (t,c); End -> Nothing })+ s <- get+ let barFrom t0 c0 = tell $ if (time2ms t - time2ms t0 < expireTimeMs conf) + then [Bar (time2ms t0) (time2ms t) c0]+ else [ExpiredBar (time2ms t0) (time2ms t0 + expireTimeMs conf) c0]+ case (s,edge) of+ (Active t0 c0, _ ) -> barFrom t0 c0+ (Phantom c0, End) -> barFrom minTime c0+ _ -> return ()+ put (case edge of { Begin c -> Active t c; End -> Inactive}) 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 track2y i = fromIntegral (i+1) * yStep - bandHeight/2+ let track2y i = fromIntegral (i+1) * yStep - (barHeight conf)/2 let drawTick ms = do { setLineStyle $ solidLine 1 (opaque black) ; moveTo $ Point (ms2x ms) (h-10)@@ -83,7 +97,7 @@ 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)) (Point (ms2x ms2) (track2y i + bandHeight)))+ ; fillPath (rectPath $ Rect (Point (ms2x ms1) (track2y i)) (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))@@ -93,7 +107,6 @@ ; strokePath [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)@@ -124,6 +137,9 @@ " -expire - 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.",+ " -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.", "", "Input is read from stdin. Example input (speaks for itself):", "2010-10-21 16:45:09,431 >foo green",@@ -144,8 +160,8 @@ ["--help"] -> showHelp >> exitSuccess _ -> return () let (w,h) = (read $ getArg "w" "640" args, read $ getArg "h" "480" args)- let bandHeight = read $ getArg "bh" "5" args- let ticksIntervalMs = read $ getArg "tickInterval" "10" args+ let barHeight = read $ getArg "bh" "5" args+ let tickIntervalMs = read $ getArg "tickInterval" "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 outPNG = getArg "o" "" args@@ -153,7 +169,8 @@ let events = parse parseTime `map` B.lines input let cmpTracks = case getArg "sort" "time" args of { "time" -> comparing time ; "name" -> comparing track } let expireTimeMs = read $ getArg "expire" "Infinity" args- let pic = renderEvents bandHeight ticksIntervalMs expireTimeMs events cmpTracks+ let phantomColor = case getArg "phantom" "" args of { "" -> Nothing; c -> Just c }+ let pic = renderEvents (RenderConf barHeight tickIntervalMs expireTimeMs cmpTracks phantomColor) events case outPNG of "" -> renderableToWindow pic w h f -> const () `fmap` renderableToPNGFile pic w h outPNG
splot.cabal view
@@ -1,5 +1,5 @@ Name: splot-Version: 0.1.5+Version: 0.1.6 License: BSD3 License-file: LICENSE Copyright: Eugene Kirpichov, 2010