splot 0.2.5 → 0.2.7
raw patch · 5 files changed
+376/−8 lines, 5 files
Files
- Tools/ColorMap.hs +82/−0
- Tools/SPlotMain.hs +7/−7
- Tools/SPlotTest.hs +39/−0
- Tools/StatePlot.hs +246/−0
- splot.cabal +2/−1
+ Tools/ColorMap.hs view
@@ -0,0 +1,82 @@+-- |Color cycling routines. +-- This module provides functions for maintaining a map from arbitrary strings to colors and +-- generating new colors for unknown names by cycling over the RGB spectrum.+-- +-- P.S. We use the spelling "color" in our identifiers for no particular reason +-- other than internal consistency.+module Tools.ColorMap (+ ColorMap,+ defaultColorMap,+ cycleColor,+ computeColor)+where+import Data.Bits+import Data.Colour+import Data.Colour.SRGB+import Data.Colour.Names+import qualified Data.ByteString.Char8 as S+import qualified Data.Map as M++data (Show b, Eq b, Ord b, Floating b) => ColorMap b = ColorMap {+ colorMap :: M.Map S.ByteString (RGB b), -- ^ Current map from arbitrary strings to color descriptions+ colorWheel :: [RGB b] -- ^ Next colors for assigning to as yet unknown names+ } deriving (Eq, Show)+ +-- | Starts with empty names-colors map and mid-range grey+defaultColorMap = ColorMap M.empty defaultColorWheel++defaultColorWheel = map toSRGB [green, blue, red, brown, orange, magenta, grey, purple, violet, lightblue, crimson, burlywood] ++ map nextColor defaultColorWheel++-- | Compute color for a given name within the associated map.+-- This function encapsulates the following rules:+-- +-- * If @color@ is a 6-digit hexadecimal value of the form '#FA34B7' then this is used as aan immediate+-- RGB color,+--+-- * If @color@ is a color name from SVG1.1 specification (http://www.w3.org/TR/SVG11/types.html#ColorKeywords)+-- then the corresponding color is returned,+--+-- * Otherwise, the @color@ name is looked up in the @map@ and if it is not found, a new color is generated+-- using a simple cycling function.+computeColor map color = case readColor color of + Nothing -> cycleColor map color+ Just c -> (c, map)+ +readColor = readColor' . S.unpack++readColor' ('#':r1:r2:g1:g2:b1:b2:[]) = Just (RGB 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'+readColor' cs = toSRGB `fmap` readColourName cs+ + +-- | Compute the color associated to a given name, providing an updated map with+-- possibly new colors in the cycle.+cycleColor :: (RealFrac b, Show b, Eq b, Ord b, Floating b) => + ColorMap b+ -> S.ByteString + -> (RGB b,ColorMap b)+cycleColor map name = case M.lookup name (colorMap map) of+ Just c -> (c, map)+ Nothing -> (next, augment map (name,next) wheel')+ where+ (next:wheel') = colorWheel map+ ++nextColor :: (RealFrac b, Floating b) => + RGB b -> + RGB b+nextColor (RGB r g b) = RGB (r+7) (g+17) (b+23)+ +augment :: (Show b, Eq b, Ord b, Floating b) => + ColorMap b -> + (S.ByteString, RGB b) -> + [RGB b] ->+ ColorMap b+augment map (name,col) wheel = ColorMap (M.insert name col (colorMap map)) wheel+
Tools/SPlotMain.hs view
@@ -12,10 +12,11 @@ import Data.Maybe(fromMaybe,isNothing) import Data.Ord(comparing) -import Control.Monad.RWS as RWS-+import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as B +import Control.Monad (when)+ import Tools.StatePlot getArg :: String -> String -> [String] -> String@@ -105,18 +106,17 @@ let inputFile = getArg "if" "-" args let pruneLF b | not (B.null b) && (B.last b == '\r') = B.init b | otherwise = b- let cmpTracks = case getArg "sort" "time" args of { "time" -> comparing time ; "name" -> comparing track }+ let cmpTracks = case getArg "sort" "time" args of { "time" -> comparing utcTime ; "name" -> comparing track } let expireTimeMs = read $ getArg "expire" "Infinity" args- let phantomColor = case getArg "phantom" "" args of { "" -> Nothing; c -> Just c }+ let phantomColor = case getArg "phantom" "" args of { "" -> Nothing; c -> Just (S.pack c) } let streaming = case getArg "stream" "false" args of { "true" -> True; _ -> False } let readInput = if inputFile == "-" then B.getContents else B.readFile inputFile let readEvents = (map (parse parseTime . pruneLF) . B.lines) `fmap` readInput when (streaming && (inputFile == "-")) $ error "In streaming mode (-stream true) you MUST use an actual filename in '-if'"- when (streaming && isNothing fromTime) $ putStrLn "Warning: without -fromTime, input will be re-scanned to compute it."- when (streaming && isNothing toTime) $ putStrLn "Warning: without -toTime, input will be re-scanned to compute it."- when (streaming && isNothing forcedNumTracks) $ putStrLn "Warning: without -numTracks, input will be re-scanned to compute it."+ when (streaming && (isNothing fromTime || isNothing toTime || isNothing forcedNumTracks)) $ do+ putStrLn "Warning: without all of -fromTime, -toTime, -numTracks, input will be scanned an extra time" pic <- renderEvents (RenderConf barHeight tickIntervalMs largeTickFreq expireTimeMs cmpTracks phantomColor fromTime toTime forcedNumTracks streaming) readEvents case outPNG of
+ Tools/SPlotTest.hs view
@@ -0,0 +1,39 @@+module Tools.SPlotTest where+import Test.HUnit++import Data.Colour+import Data.Colour.SRGB++import Tools.ColorMap++import Data.Map as M++import System.IO(stderr)+import System.Exit+++colorCyclingTests = TestList [+ cycleColor defaultColorMap "bar" ~?= (base, colorMap "bar")+ ,cycleColor (colorMap "foo") "bar" ~?= (nextColor, augmentedColorMap "bar")+ ,cycleColor (colorMap "foo") "baz" ~?= (nextColor, augmentedColorMap "baz")+ ]+ where+ base = (sRGB24 128 128 128)+ nextColor = sRGB24 (128+7) (128+17) (128+23)+ nextNextColor = sRGB24 (128+7+7) (128+17+17) (128+23+23)+ colorsAssoc name = [(name,(sRGB24 128 128 128))]+ colorMap name = ColorMap (M.fromList (colorsAssoc name)) nextColor+ augmentedColorMap name = augment (colorMap "foo") (name, nextNextColor)+ +splotTests = TestList [+ colorCyclingTests + ]+ +runAllTests tests = do counts <- runTest tests+ case (errors counts + failures counts) of+ 0 -> return ExitSuccess+ n -> return (ExitFailure n)++runTest :: Test -> IO Counts+runTest t = do (counts, _) <- runTestText (putTextToHandle stderr False) t+ return counts
+ Tools/StatePlot.hs view
@@ -0,0 +1,246 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}+module Tools.StatePlot 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 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+import Data.Colour.Names++import Tools.ColorMap++import Debug.Trace++data Event = Event { localTime :: !LocalTime, utcTime :: !UTCTime, track :: !S.ByteString, edge :: !Edge } deriving (Show)+data Edge = Begin { color :: !S.ByteString } | End { color :: !S.ByteString } | Pulse { glyph :: !Glyph, color :: !S.ByteString } deriving (Show)++-- Text is enough for most purposes (|, o, <, >, ...) but potentially more can exist.+data Glyph = GlyphText { text :: !S.ByteString } deriving (Show)++data OutputGlyph = Bar {-# UNPACK #-} !Double !Double !S.ByteString + | ExpiredBar {-# UNPACK #-} !Double !Double !S.ByteString + | OutPulse {-# UNPACK #-} !Double !Glyph !S.ByteString deriving (Show)++parse :: (B.ByteString -> (LocalTime, B.ByteString)) -> B.ByteString -> Event+parse parseTime s = Event { localTime = ts, utcTime = localTimeToUTC utc ts, track = repack $ B.tail track', edge = edge }+ where+ (ts, s') = parseTime s+ (track', arg0) = B.break (==' ') (B.tail s')+ arg = if B.null arg0 then S.empty else repack (B.tail arg0)+ edge = case (B.head track') of+ '>' -> Begin (if S.null arg then grayStr else arg)+ '<' -> End (if S.null arg then S.empty else arg)+ '!' -> Pulse (GlyphText text) color+ where (color, text0) = S.break (==' ') arg+ text = S.tail text0++repack = S.concat . B.toChunks++grayStr = S.pack "gray"++{-# INLINE diffToMillis #-}+diffToMillis :: UTCTime -> UTCTime -> Double+diffToMillis !t2 !t1 = 86400000.0 * fromIntegral dd + fromRational (toRational (tod2-tod1))*1000.0+ where+ (d1,d2,tod1,tod2) = (utctDay t1, utctDay t2, utctDayTime t1, utctDayTime t2)+ dd = toModifiedJulianDay d2 - toModifiedJulianDay d1++data BarHeight = BarHeightFixed Double | BarHeightFill++data RenderConfiguration = RenderConf {+ barHeight :: BarHeight,+ tickIntervalMs :: Double,+ largeTickFreq :: Int,+ expireTimeMs :: Double,+ cmpTracks :: Event -> Event -> Ordering,+ phantomColor :: Maybe S.ByteString,+ fromTime :: Maybe LocalTime,+ toTime :: Maybe LocalTime,+ forcedNumTracks :: Maybe Int,+ streaming :: Bool+ }++data TickSize = LargeTick | SmallTick++newtype RenderState s a = RenderState { runRenderState :: StateT s CRender a } deriving (Monad, MonadState s)++liftR :: CRender () -> RenderState s ()+liftR r = RenderState $ lift r++renderEvents :: RenderConfiguration -> IO [Event] -> IO (Renderable ())+renderEvents conf readEs = if streaming conf + then return (Renderable {minsize = return (0,0), render = renderGlyphsAtFront (c $ liftIO readEs)})+ else readEs >>= \es -> return $ Renderable {minsize = return (0,0), render = renderGlyphsAtFront (return es)}+ where + {-# INLINE maybeM #-}+ maybeM :: (Monad m) => (a -> m b) -> Maybe a -> m ()+ maybeM f Nothing = return ()+ maybeM f (Just x) = f x >> return ()++ -- Returns: whether we have any non-bars glyphs (text)+ genGlyphs :: (UTCTime -> Double) -> Double -> [Event] -> Bool -> (Int -> OutputGlyph -> RenderState s ()) -> RenderState s Bool+ genGlyphs time2ms !rangeMs es drawGlyphsNotBars withGlyph = genGlyphs' es M.empty False+ where+ genGlyphs' [] m !havePulses = when (not drawGlyphsNotBars) (mapM_ flushTrack (M.toList m)) >> return havePulses+ 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)+ genGlyphs' ((e@(Event _ t track edge)):es) m !havePulses = do+ let mst = time2ms t+ ((i,ms0), m') <- summon e mst m+ let isPulse = case edge of {Pulse{} -> True; _ -> False}+ if drawGlyphsNotBars + then do+ case edge of {Pulse glyph c -> withGlyph i (OutPulse mst glyph c); _ -> return ()}+ genGlyphs' es m' (havePulses || isPulse)+ else 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))+ let m'' = M.insert track (i, case edge of { Begin c -> Just (mst,c); End _ -> Nothing }) m'+ genGlyphs' es m'' (havePulses || isPulse)+ + summon (Event _ t track edge) mst m = case M.lookup track m of+ Just x -> return (x, m)+ Nothing -> do+ let i = M.size m+ let m' = M.insert track (i, Nothing) m+ when (not drawGlyphsNotBars) $ case (phantomColor conf, edge) of+ (_, End c) | not (S.null c) -> withGlyph i (Bar 0 mst c)+ (Just c, End _) -> withGlyph i (Bar 0 mst c)+ _ -> return ()+ return ((i,Nothing), m')++ renderGlyphsAtFront :: CRender [Event] -> (Double,Double) -> CRender (PickFn a)+ renderGlyphsAtFront readEs (w,h) = do+ setFillStyle $ solidFillStyle (opaque white)+ fillPath $ rectPath $ Rect (Point 0 0) (Point 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+ (Just a, Just b, m) = foldl' f (Nothing, Nothing, M.empty) es+ f (!minRT, !maxRT, !tracks) e = (orJust min minRT (localTime e), orJust max maxRT (localTime e), M.insert (track e) () tracks)+ orJust f Nothing x = Just x+ orJust f (Just x0) x = Just (f x0 x)++ override (ft, tt, nt) = (override' ft (fromTime conf), override' tt (toTime conf), override' nt (forcedNumTracks conf))+ override' x (Just y) = y+ override' x Nothing = x++ render' :: CRender [Event] -> (Double,Double) -> Bool -> CRender Bool+ render' readEs (w,h) drawGlyphsNotBars = do+ es <- readEs++ (minRenderLocalTime, maxRenderLocalTime, numTracks) <- case (fromTime conf, toTime conf, forcedNumTracks conf, streaming conf) of+ (Just a, Just b, Just c, _) -> return (a, b, c)+ (_, _, _, True) -> fmap (override . computeTimesTracks) readEs+ (_, _, _, False) -> return $ override (computeTimesTracks es) -- Will evaluate the whole of 'es' and hold it in memory++ let (minRenderTime, maxRenderTime) = (localTimeToUTC utc minRenderLocalTime, localTimeToUTC utc maxRenderLocalTime)+ let rangeMs = diffToMillis maxRenderTime minRenderTime++ let time2ms t | t < minRenderTime = 0+ | t > maxRenderTime = rangeMs+ | otherwise = diffToMillis t minRenderTime++ let ticks = takeWhile ((<rangeMs).snd) $ + map (\i -> if i`mod`largeTickFreq conf == 0 + then (LargeTick, fromIntegral i*tickIntervalMs conf) + else (SmallTick, fromIntegral i*tickIntervalMs conf)) [0..]++ let ms2x ms = 10 + ms / rangeMs * (w - 10)+ 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) (h-20)+ ; C.lineTo (ms2x ms) (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 getColor :: S.ByteString -> RenderState (ColorMap Double) (RGB Double)+ getColor c = do {+ map <- ST.get+ ; let (color, map') = computeColor map c+ ; ST.put map'+ ; return color+ }++ let drawGlyph :: Int -> OutputGlyph -> RenderState (ColorMap Double) ()+ 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 ()+ }+ 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 ()+ }+ 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 ()+ }+ }++ setLineStyle $ solidLine 1 (opaque black)+ moveTo (Point 10 (h-20))+ lineTo (Point w (h-20))+ c $ C.stroke+ moveTo (Point 10 (h-20))+ lineTo (Point 10 0)+ c $ C.stroke+ moveTo (Point 10 (h-3))+ c $ C.showText $ "Origin at " ++ show minRenderLocalTime ++ ", 1 small tick = " ++ show (tickIntervalMs conf) ++ "ms"+ setLineStyle $ solidLine 1 (opaque black)+ mapM_ drawTick ticks++ let colorMap = defaultColorMap+ evalStateT (runRenderState $ genGlyphs time2ms rangeMs es drawGlyphsNotBars drawGlyph) defaultColorMap
splot.cabal view
@@ -1,5 +1,5 @@ Name: splot-Version: 0.2.5+Version: 0.2.7 License: BSD3 License-file: LICENSE Copyright: Eugene Kirpichov, 2010@@ -29,5 +29,6 @@ Build-Depends: cairo, bytestring, bytestring-lexing, strptime >= 0.1.7, time, containers, colour, Chart, mtl, HUnit+ Other-Modules: Tools.ColorMap Tools.SPlotTest Tools.SPlotTest Tools.StatePlot Main-Is: Tools/SPlotMain.hs Ghc-Options: -O2 -rtsopts