diff --git a/Scope/Cairo.hs b/Scope/Cairo.hs new file mode 100644 --- /dev/null +++ b/Scope/Cairo.hs @@ -0,0 +1,76 @@ +{-# OPTIONS -Wall -fno-warn-orphans #-} + +module Scope.Cairo ( + -- * Types + ViewCairo(..) + + -- * Scope ViewCairo + , scopeCairoNew + , viewCairoInit + + -- * Utils + , keepState +) where + +import Prelude hiding (catch) + +import Control.Monad.CatchIO +import Control.Monad.Reader +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Cairo.Internal (Render(..)) +import Graphics.Rendering.Cairo.Types (Cairo) +import qualified Graphics.UI.Gtk as G + +import Scope.Types hiding (m, b) + +---------------------------------------------------------------------- + +data ViewCairo = ViewCairo + { canvas :: G.DrawingArea + , adj :: G.Adjustment + } + +scopeCairoNew :: G.DrawingArea -> G.Adjustment -> Scope ViewCairo +scopeCairoNew c a = scopeNew (viewCairoInit c a) + +viewCairoInit :: G.DrawingArea -> G.Adjustment -> ViewCairo +viewCairoInit c a = ViewCairo c a + +---------------------------------------------------------------------- + +instance MonadCatchIO C.Render where + m `catch` f = mapRender (\m' -> m' `catch` \e -> runRender $ f e) m + block = mapRender block + unblock = mapRender unblock + +mapRender :: (ReaderT Cairo IO m1 -> ReaderT Cairo IO m) -> Render m1 -> Render m +mapRender f = Render . f . runRender + +instance ScopeRender C.Render where + renderCmds = keepState . mapM_ cairoDrawCmd + +---------------------------------------------------------------------- + +cairoDrawCmd :: DrawCmd -> C.Render () +cairoDrawCmd (SetRGB r g b) = C.setSourceRGB r g b +cairoDrawCmd (SetRGBA r g b a) = C.setSourceRGBA r g b a +cairoDrawCmd (MoveTo (x,y)) = C.moveTo x y + +cairoDrawCmd (LineTo (x,y)) = do + C.lineTo x y + C.stroke + +cairoDrawCmd (FillPoly []) = return () +cairoDrawCmd (FillPoly ((x,y):ps)) = do + C.moveTo x y + mapM_ (uncurry C.lineTo) ps + C.fill + +---------------------------------------------------------------- + +keepState :: C.Render t -> C.Render () +keepState render = do + C.save + _ <- render + C.restore + diff --git a/Scope/Layer.hs b/Scope/Layer.hs new file mode 100644 --- /dev/null +++ b/Scope/Layer.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +{- | + Module : Scope.Layer + Copyright : Conrad Parker + License : BSD3-style (see LICENSE) + + Maintainer : Conrad Parker + Stability : unstable + Portability : unknown + + Layers + +-} +---------------------------------------------------------------------- + +module Scope.Layer ( + -- * Layers + addLayersFromFile + , plotLayers +) where + +import Control.Applicative ((<$>), (<*>), (<|>)) +import Control.Monad (join, replicateM, (>=>)) +import Control.Monad.Trans (lift) +import Data.Function (on) +import qualified Data.IntMap as IM +import qualified Data.Iteratee as I +import Data.List (groupBy) +import Data.Maybe (fromJust, listToMaybe) +import Data.Time.Clock +import Data.ZoomCache.Multichannel +import Data.ZoomCache.Numeric +import qualified System.Random.MWC as MWC + +import Scope.Plot +import Scope.Types hiding (b) +import Scope.View + +---------------------------------------------------------------------- +-- Random, similar colors + +type RGB = (Double, Double, Double) + +genColor :: RGB -> Double -> MWC.GenIO -> IO RGB +genColor (r, g, b) a gen = do + let a' = 1.0 - a + r' <- MWC.uniformR (0.0, a') gen + g' <- MWC.uniformR (0.0, a') gen + b' <- MWC.uniformR (0.0, a') gen + return (r*a + r', g*a + g', b*a * b') + +genColors :: Int -> RGB -> Double -> IO [RGB] +genColors n rgb a = MWC.withSystemRandom (replicateM n . genColor rgb a) + +---------------------------------------------------------------------- + +layersFromFile :: FilePath -> IO ([ScopeLayer], Maybe (TimeStamp, TimeStamp), Maybe (UTCTime, UTCTime)) +layersFromFile path = do + cf <- I.fileDriverRandom (iterHeaders standardIdentifiers) path + let base = baseUTC . cfGlobal $ cf + tracks = IM.keys . cfSpecs $ cf + colors <- genColors (length tracks) (0.9, 0.9, 0.9) (0.5) + foldl1 merge <$> mapM (\t -> I.fileDriverRandom (iterListLayers base t) path) + (zip tracks colors) + where + merge :: ([ScopeLayer], Maybe (TimeStamp, TimeStamp), Maybe (UTCTime, UTCTime)) + -> ([ScopeLayer], Maybe (TimeStamp, TimeStamp), Maybe (UTCTime, UTCTime)) + -> ([ScopeLayer], Maybe (TimeStamp, TimeStamp), Maybe (UTCTime, UTCTime)) + merge (ls1, bs1, ubs1) (ls2, bs2, ubs2) = + (ls1 ++ ls2, unionBounds bs1 bs2, unionBounds ubs1 ubs2) + + iterListLayers base (trackNo, color) = listLayers base trackNo color <$> + wholeTrackSummaryListDouble standardIdentifiers trackNo + + listLayers :: Maybe UTCTime -> TrackNo -> RGB -> [Summary Double] + -> ([ScopeLayer], Maybe (TimeStamp, TimeStamp), Maybe (UTCTime, UTCTime)) + listLayers base trackNo rgb ss = ([ ScopeLayer (rawListLayer base trackNo ss) + , ScopeLayer (sListLayer base trackNo rgb ss) + ] + , Just (entry, exit) + , utcBounds (entry, exit) <$> base) + where + s = head ss + entry = summaryEntry s + exit = summaryExit s + utcBounds (t1, t2) b = (ub t1, ub t2) + where + ub = utcTimeFromTimeStamp b + + rawListLayer :: Maybe UTCTime -> TrackNo + -> [Summary Double] -> Layer (TimeStamp, [Double]) + rawListLayer base trackNo ss = Layer path trackNo + base + (summaryEntry s) (summaryExit s) + enumListDouble (LayerFold (plotRawList (maxRange ss)) plotRawListInit Nothing) + where + s = head ss + + sListLayer :: Maybe UTCTime -> TrackNo -> RGB + -> [Summary Double] -> Layer [Summary Double] + sListLayer base trackNo (r, g, b) ss = Layer path trackNo + base + (summaryEntry s) (summaryExit s) + (enumSummaryListDouble 1) + (LayerFold (plotSummaryList (maxRange ss)) (plotSummaryListInit r g b) Nothing) + where + s = head ss + + maxRange :: [Summary Double] -> Double + maxRange = maximum . map yRange + + yRange :: Summary Double -> Double + yRange s = 2 * ((abs . numMin . summaryData $ s) + (abs . numMax . summaryData $ s)) + +addLayersFromFile :: FilePath -> Scope ui -> IO (Scope ui) +addLayersFromFile path scope = do + (newLayers, newBounds, newUTCBounds) <- layersFromFile path + let scope' = scopeUpdate newBounds newUTCBounds scope + return $ scope' { layers = layers scope ++ newLayers } + +---------------------------------------------------------------- + +plotLayers :: ScopeRender m => Scope ui -> m () +plotLayers scope = mapM_ f layersByFile + where + f :: ScopeRender m => [ScopeLayer] -> m () + f ls = plotFileLayers (fn . head $ ls) ls scope + layersByFile = groupBy ((==) `on` fn) (layers scope) + fn (ScopeLayer l) = filename l + +plotFileLayers :: ScopeRender m => FilePath -> [ScopeLayer] -> Scope ui -> m () +plotFileLayers path layers scope = + flip I.fileDriverRandom path $ do + I.joinI $ enumCacheFile identifiers $ do + seekTimeStamp seekStart + I.joinI . (I.takeWhileE (before seekEnd) >=> I.take 1) $ I.sequence_ is + where + v = view scope + identifiers = standardIdentifiers + is = map (plotLayer scope) layers + + seekStart = ts (viewStartUTC scope v) <|> viewStartTime scope v + seekEnd = ts (viewEndUTC scope v) <|> viewEndTime scope v + + ts = (timeStampFromUTCTime <$> base <*>) + base :: Maybe UTCTime + base = join . listToMaybe $ lBase <$> take 1 layers + lBase (ScopeLayer l) = layerBaseUTC l + +plotLayer :: ScopeRender m => Scope ui -> ScopeLayer -> I.Iteratee [Stream] m () +plotLayer scope (ScopeLayer Layer{..}) = + I.joinI . filterTracks [layerTrackNo] . I.joinI . convEnee $ render plotter + where + render (LayerMap f initCmds) = do + d0'm <- I.tryHead + case d0'm of + Just d0 -> do + asdf <- I.foldM renderMap (toX d0, initCmds) + lift $ mapM_ renderCmds (snd asdf) + Nothing -> return () + where + renderMap (x0, prev) d = do + let x = toX d + cmds = f x0 (x-x0) d + return (x, zipWith (++) prev cmds) + render (LayerFold f initCmds b00) = do + d0'm <- I.tryHead + case d0'm of + Just d0 -> do + asdf <- I.foldM renderFold (toX d0, initCmds, b00) + lift $ mapM_ renderCmds (mid asdf) + Nothing -> return () + where + renderFold (x0, prev, b0) d = do + let x = toX d + (cmds, b) = f x0 (x-x0) b0 d + return (x, zipWith (++) prev cmds, b) + mid (_,x,_) = x + + toX :: Timestampable a => a -> Double + toX = case (utcBounds scope, layerBaseUTC) of + (Just _, Just base) -> toUTCX base + _ -> toTSX + + toTSX :: Timestampable a => a -> Double + toTSX = toDouble . timeStampToCanvas scope . fromJust . timestamp + + toUTCX :: Timestampable a => UTCTime -> a -> Double + toUTCX base = toDouble . utcToCanvas scope . utcTimeFromTimeStamp base . fromJust . timestamp diff --git a/Scope/Plot.hs b/Scope/Plot.hs new file mode 100644 --- /dev/null +++ b/Scope/Plot.hs @@ -0,0 +1,105 @@ +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +{- | + Module : Scope.Plot + Copyright : Conrad Parker + License : BSD3-style (see LICENSE) + + Maintainer : Conrad Parker + Stability : unstable + Portability : unknown + + Scope plotting functions +-} + +module Scope.Plot ( + plotRawListInit + , plotRawList + , plotSummaryListInit + , plotSummaryList +) where + +import Control.Arrow (second) +import Data.Maybe (fromJust) +import Data.ZoomCache +import Data.ZoomCache.Numeric + +import Scope.Types hiding (b) + +---------------------------------------------------------------------- +-- Raw data + +plotRawListInit :: [DrawLayer] +plotRawListInit = repeat [] + +plotRawList :: Double -> LayerFoldFunc (TimeStamp, [Double]) (Maybe [Double]) +plotRawList yRange x w Nothing (ts, ys) = plotRawList yRange x w (Just ys) (ts, ys) +plotRawList yRange x w (Just ys0) (ts, ys) = + second Just $ foldl c ([], []) $ map f (zip3 (map yFunc [0..]) ys0 ys) + where + c :: ([a], [b]) -> ([a], b) -> ([a], [b]) + c (ds0, ss) (ds, s) = (ds0++ds, ss++[s]) + + l = length ys + yStep = 2.0 / fromIntegral l + yFunc n v = (-1.0) + (n * yStep) + ((0.5) * yStep) + (v * yStep / yRange) + f :: ((Double -> Double), Double, Double) -> ([DrawLayer], Double) + f (y, s0, s) = second fromJust $ plotRaw1 y x w (Just s0) (ts, s) + +plotRaw1 :: (Double -> Double) -> LayerFoldFunc (TimeStamp, Double) (Maybe Double) +plotRaw1 f x w Nothing (ts, y) = plotRaw1 f x w (Just y) (ts, y) +plotRaw1 f x w (Just y0) (_ts, y) = (cmds, Just y') + where + cmds = + [ [ MoveTo (x, y0) + , LineTo (x+w, y') + ] + ] + y' = f y + +---------------------------------------------------------------------- +-- Summary data + +plotSummaryListInit :: Double -> Double -> Double -> [DrawLayer] +plotSummaryListInit r g b = concat $ repeat + [ [ SetRGBA r g b 0.3 ] + , [ SetRGB (r*0.6) (g*0.6) (b*0.6) ] + ] + +plotSummaryList :: Double + -> LayerFoldFunc [Summary Double] (Maybe [Summary Double]) +plotSummaryList dYRange x w Nothing ss = + plotSummaryList dYRange x w (Just ss) ss +plotSummaryList dYRange x w (Just ss0) ss = do + second Just $ foldl c ([], []) $ map f (zip3 (map yFunc [0..]) ss0 ss) + where + c :: ([a], [b]) -> ([a], b) -> ([a], [b]) + c (ds0, sss) (ds, s) = (ds0++ds, sss++[s]) + + l = length ss + yStep = 2.0 / fromIntegral l + yFunc n v = (-1.0) + (n * yStep) + ((0.5) * yStep) + (v * yStep / dYRange) + f :: ((Double -> Double), Summary Double, Summary Double) -> ([DrawLayer], Summary Double) + f (y, s0, s) = second fromJust $ plotSummary1 y x w (Just s0) s + +-- | Plot one numeric summary +plotSummary1 :: (Double -> Double) + -> LayerFoldFunc (Summary Double) (Maybe (Summary Double)) +plotSummary1 y x w Nothing s = + plotSummary1 y x w (Just s) s +plotSummary1 y x w (Just s0) s = (cmds, Just s) + where + cmds = + [ [ FillPoly [ (x, y (numMax sd0)) + , ((x+w), y (numMax sd)) + , ((x+w), y (numMin sd)) + , (x, y (numMin sd0)) + ] + ] + , [ MoveTo (x, y (numAvg sd0)) + , LineTo ((x+w), y (numAvg sd)) + ] + ] + sd0 = summaryData s0 + sd = summaryData s + diff --git a/Scope/Types.hs b/Scope/Types.hs --- a/Scope/Types.hs +++ b/Scope/Types.hs @@ -49,16 +49,23 @@ , mkTransform , mkTSDataTransform + , unionBounds , translateRange , unionRange , restrictRange , restrictRange01 , zoomRange + -- * Drawing commands + , DrawCmd(..) + , DrawLayer + , ScopeRender(..) + -- * Scope , Scope(..) , scopeNew - , scopeTransform + , scopeUpdate + , scopeModifyView -- * Views , View(..) @@ -72,13 +79,12 @@ ) where import Control.Applicative ((<$>)) +import Control.Monad.CatchIO +import Data.Time.Clock import Data.Maybe import Data.Iteratee (Enumeratee) import Data.ZoomCache -import qualified Graphics.Rendering.Cairo as C -import qualified Graphics.UI.Gtk as G - ---------------------------------------------------------------------- data Transform a = Transform { m :: Double, b :: a } @@ -136,6 +142,21 @@ translate (TS t) (TS x) = TS (translate t x) transform (Transform m (TS b)) (TS x) = TS (transform (Transform m b) x) +instance Coordinate UTCTime where + fromDouble d = addUTCTime (fromRational . toRational $ d) utc0 + toDouble u = fromRational . toRational $ diffUTCTime u utc0 + distance u1 u2 = fromDouble (distance (toDouble u1) (toDouble u2)) + translate t u = fromDouble (translate (toDouble t) (toDouble u)) + transform (Transform m b) x = fromDouble (transform (Transform m (toDouble b)) (toDouble x)) + +utc0 :: UTCTime +utc0 = UTCTime (toEnum 0) (fromInteger 0) + +unionBounds :: Ord a => Maybe (a, a) -> Maybe (a, a) -> Maybe (a, a) +unionBounds a Nothing = a +unionBounds Nothing b = b +unionBounds (Just r1) (Just r2) = Just (unionRange r1 r2) + translateRange :: Coordinate a => a -> (a, a) -> (a, a) translateRange t (x1, x2) = (translate t x1, translate t x2) @@ -181,25 +202,50 @@ m = toDouble oldW / toDouble newW b = fromDouble $ toDouble (distance new1 old1) / toDouble newW +mkUTCDataTransform :: (UTCTime, UTCTime) -> (UTCTime, UTCTime) -> Transform DataX +mkUTCDataTransform (old1, old2) (new1, new2) = Transform m b + where + oldW = distance old1 old2 + newW = distance new1 new2 + m = toDouble oldW / toDouble newW + b = fromDouble $ toDouble (distance new1 old1) / toDouble newW + ---------------------------------------------------------------------- +data DrawCmd = + SetRGB Double Double Double + | SetRGBA Double Double Double Double + | MoveTo (Double, Double) + | LineTo (Double, Double) + | FillPoly [(Double, Double)] + +---------------------------------------------------------------------- + +class (Functor m, MonadCatchIO m) => ScopeRender m where + renderCmds :: [DrawCmd] -> m () + +---------------------------------------------------------------------- + +type DrawLayer = [DrawCmd] + -- | A layer plotting function which is just given the x position and x width -- to render the data value of type 'a' into. -type LayerMapFunc a = Double -> Double -> a -> C.Render () +type LayerMapFunc a = Double -> Double -> a -> [DrawLayer] -- | A layer plotting function which is given the x position and x width, -- and a previously returned value of type 'b' -type LayerFoldFunc a b = Double -> Double -> b -> a -> C.Render b +type LayerFoldFunc a b = Double -> Double -> b -> a -> ([DrawLayer], b) -data LayerPlot a = LayerMap (LayerMapFunc a) - | forall b . LayerFold (LayerFoldFunc a b) b +data LayerPlot a = LayerMap (LayerMapFunc a) [DrawLayer] + | forall b . LayerFold (LayerFoldFunc a b) [DrawLayer] b data Layer a = Layer { filename :: FilePath - , trackNo :: TrackNo + , layerTrackNo :: TrackNo + , layerBaseUTC :: Maybe UTCTime , startTime :: TimeStamp , endTime :: TimeStamp - , convEnee :: Enumeratee [Stream] [a] C.Render () + , convEnee :: forall m . (Functor m, Monad m) => Enumeratee [Stream] [a] m () , plotter :: LayerPlot a } @@ -207,41 +253,73 @@ ---------------------------------------------------------------------- -data Scope = Scope - { view :: View +data Scope ui = Scope + { view :: View ui , bounds :: Maybe (TimeStamp, TimeStamp) + , utcBounds :: Maybe (UTCTime, UTCTime) , layers :: [ScopeLayer] } -data View = View - { canvas :: G.DrawingArea - , adj :: G.Adjustment - , viewX1 :: DataX +data View ui = View + { viewX1 :: DataX , viewY1 :: Double , viewX2 :: DataX , viewY2 :: Double , pointerX :: Maybe CanvasX , dragDX :: Maybe DataX -- DataX of pointer at drag down + , viewUI :: ui } -scopeNew :: G.DrawingArea -> G.Adjustment -> Scope -scopeNew c adj = Scope { - view = viewInit c adj +scopeNew :: ui -> Scope ui +scopeNew ui = Scope { + view = viewInit ui , bounds = Nothing + , utcBounds = Nothing , layers = [] } -scopeTransform :: Transform DataX -> Scope -> Scope -scopeTransform tf scope@Scope{..} = scope { view = viewTransform tf view } +scopeModifyView :: (View ui -> View ui) -> Scope ui -> Scope ui +scopeModifyView f scope = scope{ view = f (view scope) } -viewInit :: G.DrawingArea -> G.Adjustment -> View -viewInit c adj = View c adj (DataX 0.0) (-1.0) (DataX 1.0) 1.0 Nothing Nothing +scopeTransform :: Transform DataX -> Scope ui -> Scope ui +scopeTransform tf = scopeModifyView (viewTransform tf) -viewTransform :: Transform DataX -> View -> View +viewInit :: ui -> View ui +viewInit = View (DataX 0.0) (-1.0) (DataX 1.0) 1.0 Nothing Nothing + +viewTransform :: Transform DataX -> View ui -> View ui viewTransform tf v@View{..} = v { viewX1 = transform tf viewX1 , viewX2 = transform tf viewX2 , dragDX = transform tf <$> dragDX } + +scopeUpdate :: Maybe (TimeStamp, TimeStamp) + -> Maybe (UTCTime, UTCTime) + -> Scope ui -> Scope ui +scopeUpdate newBounds Nothing scope = + (t scope) { bounds = mb , utcBounds = Nothing } + where + oldBounds = bounds scope + mb = unionBounds oldBounds newBounds + t = case oldBounds of + Just ob -> if oldBounds == mb + then id + else scopeTransform (mkTSDataTransform ob (fromJust mb)) + _ -> id + +scopeUpdate newBounds (Just newUTCBounds) scope + | (not . null . layers $ scope) && isNothing oldUTCBounds = scopeUpdate newBounds Nothing scope + | otherwise = (t scope) { bounds = mb , utcBounds = umb } + where + oldBounds = bounds scope + oldUTCBounds = utcBounds scope + mb = unionBounds oldBounds newBounds + umb = unionBounds oldUTCBounds (Just newUTCBounds) + t = case oldUTCBounds of + Just uob -> if oldUTCBounds == umb + then id + else scopeTransform (mkUTCDataTransform uob (fromJust umb)) + _ -> id ---------------------------------------------------------------------- diff --git a/Scope/View.hs b/Scope/View.hs --- a/Scope/View.hs +++ b/Scope/View.hs @@ -18,14 +18,27 @@ timeStampToData , dataToTimeStamp , timeStampToCanvas + , dataToUTC + , utcToCanvas + , viewStartUTC + , viewEndUTC , viewStartTime , viewEndTime , viewDuration - -- * Motion, zooming + -- * Motion , viewAlign + , viewMoveStart + , viewMoveEnd + , viewMoveLeft + , viewMoveRight , viewMoveTo + + -- * Zoom + , viewZoomIn + , viewZoomOut + , viewZoomInOn , viewZoomOutOn -- * Button handling @@ -35,29 +48,39 @@ ) where import Data.Maybe (fromJust) +import Data.Time (UTCTime) import Data.ZoomCache import Scope.Types ---------------------------------------------------------------------- -canvasToData :: View -> CanvasX -> DataX +canvasToData :: View ui -> CanvasX -> DataX canvasToData View{..} (CanvasX cX) = translate viewX1 $ DataX (cX * toDouble (distance viewX1 viewX2)) -timeStampToData :: Scope -> TimeStamp -> Maybe DataX +timeStampToData :: Scope ui -> TimeStamp -> Maybe DataX timeStampToData Scope{..} (TS ts) = fmap tsToData bounds where tsToData :: (TimeStamp, TimeStamp) -> DataX tsToData (TS t1, TS t2) = DataX $ ts - t1 / (t2 - t1) -dataToTimeStamp :: Scope -> DataX -> Maybe TimeStamp +dataToTimeStamp :: Scope ui -> DataX -> Maybe TimeStamp dataToTimeStamp Scope{..} (DataX dX) = fmap dataToTS bounds where dataToTS :: (TimeStamp, TimeStamp) -> TimeStamp dataToTS (TS t1, TS t2) = TS $ t1 + dX * (t2 - t1) -timeStampToCanvas :: Scope -> TimeStamp -> CanvasX +dataToUTC :: Scope ui -> DataX -> Maybe UTCTime +dataToUTC Scope{..} (DataX dX) = fmap dToUTC utcBounds + where + dToUTC :: (UTCTime, UTCTime) -> UTCTime + dToUTC (u1, u2) = fromDouble $ t1 + dX * (t2 - t1) + where + t1 = toDouble u1 + t2 = toDouble u2 + +timeStampToCanvas :: Scope ui -> TimeStamp -> CanvasX timeStampToCanvas scope ts = CanvasX $ toDouble (distance vt1 ts) / toDouble (distance vt1 vt2) where @@ -65,15 +88,29 @@ vt1 = fromJust $ dataToTimeStamp scope (viewX1 v) vt2 = fromJust $ dataToTimeStamp scope (viewX2 v) +utcToCanvas :: Scope ui -> UTCTime -> CanvasX +utcToCanvas scope u = CanvasX $ + toDouble (distance vt1 u) / toDouble (distance vt1 vt2) + where + v = view scope + vt1 = fromJust $ dataToUTC scope (viewX1 v) + vt2 = fromJust $ dataToUTC scope (viewX2 v) + ---------------------------------------------------------------------- -viewStartTime :: Scope -> View -> Maybe TimeStamp +viewStartUTC :: Scope ui -> View ui -> Maybe UTCTime +viewStartUTC scope View{..} = dataToUTC scope viewX1 + +viewEndUTC :: Scope ui -> View ui -> Maybe UTCTime +viewEndUTC scope View{..} = dataToUTC scope viewX2 + +viewStartTime :: Scope ui -> View ui -> Maybe TimeStamp viewStartTime scope View{..} = dataToTimeStamp scope viewX1 -viewEndTime :: Scope -> View -> Maybe TimeStamp +viewEndTime :: Scope ui -> View ui -> Maybe TimeStamp viewEndTime scope View{..} = dataToTimeStamp scope viewX2 -viewDuration :: Scope -> View -> Maybe TimeStampDiff +viewDuration :: Scope ui -> View ui -> Maybe TimeStampDiff viewDuration scope view = case (viewStartTime scope view, viewEndTime scope view) of (Just s, Just e) -> Just $ timeStampDiff e s @@ -81,12 +118,12 @@ ---------------------------------------------------------------------- -viewSetEnds :: DataX -> DataX -> View -> View +viewSetEnds :: DataX -> DataX -> View ui -> View ui viewSetEnds x1 x2 v@View{..} = v { viewX1 = x1, viewX2 = x2 } -- | Align a view so the given DataX appears at CanvasX, -- preserving the current view width. -viewAlign :: CanvasX -> DataX -> View -> View +viewAlign :: CanvasX -> DataX -> View ui -> View ui viewAlign (CanvasX cx) (DataX dx) v@View{..} = viewSetEnds (DataX newX1') (DataX newX2') v where DataX vW = distance viewX1 viewX2 -- current width of view window @@ -94,30 +131,51 @@ newX2 = newX1 + vW (newX1', newX2') = restrictRange01 (newX1, newX2) -viewMoveTo :: Double -> View -> View +viewMoveStart :: View ui -> View ui +viewMoveStart = viewAlign (CanvasX 0.0) (DataX 0.0) + +viewMoveEnd :: View ui -> View ui +viewMoveEnd = viewAlign (CanvasX 1.0) (DataX 1.0) + +viewMoveLeft :: View ui -> View ui +viewMoveLeft v@View{..} = viewAlign (CanvasX 0.0) viewX2 v + +viewMoveRight :: View ui -> View ui +viewMoveRight v@View{..} = viewAlign (CanvasX 1.0) viewX1 v + +viewMoveTo :: Double -> View ui -> View ui viewMoveTo val v@View{..} = viewSetEnds newX1' newX2' v where (newX1', newX2') = restrictRange01 . translateRange (distance viewX1 (DataX val)) $ (viewX1, viewX2) -viewZoomOutOn :: CanvasX -> Double -> View -> View +viewZoomIn :: Double -> View ui -> View ui +viewZoomIn = viewZoomInOn (CanvasX 0.5) + +viewZoomInOn :: CanvasX -> Double -> View ui -> View ui +viewZoomInOn focus mult = viewZoomOutOn focus (1.0/mult) + +viewZoomOut :: Double -> View ui -> View ui +viewZoomOut = viewZoomOutOn (CanvasX 0.5) + +viewZoomOutOn :: CanvasX -> Double -> View ui -> View ui viewZoomOutOn focus mult v@View{..} = viewSetEnds newX1 newX2' v where (newX1, newX2') = restrictRange01 $ zoomRange focus mult (viewX1, viewX2) -viewButtonDown :: CanvasX -> View -> View +viewButtonDown :: CanvasX -> View ui -> View ui viewButtonDown cX v = v { dragDX = Just (canvasToData v cX) } -viewButtonMotion :: CanvasX -> View -> View +viewButtonMotion :: CanvasX -> View ui -> View ui viewButtonMotion cX v@View{..} = case dragDX of Just dX -> viewAlign cX dX v' Nothing -> v' where v' = v { pointerX = Just cX } -viewButtonRelease :: View -> View +viewButtonRelease :: View ui -> View ui viewButtonRelease v = v { dragDX = Nothing} ---------------------------------------------------------------------- diff --git a/demo/demo1.zoom b/demo/demo1.zoom Binary files a/demo/demo1.zoom and b/demo/demo1.zoom differ diff --git a/demo/demo2.zoom b/demo/demo2.zoom Binary files a/demo/demo2.zoom and b/demo/demo2.zoom differ diff --git a/demo/demo3.zoom b/demo/demo3.zoom Binary files a/demo/demo3.zoom and b/demo/demo3.zoom differ diff --git a/demo/demo4.zoom b/demo/demo4.zoom Binary files a/demo/demo4.zoom and b/demo/demo4.zoom differ diff --git a/scope.cabal b/scope.cabal --- a/scope.cabal +++ b/scope.cabal @@ -1,6 +1,6 @@ Name: scope -Version: 0.5.2.0 +Version: 0.6.0.0 Synopsis: An interactive renderer for plotting time-series data @@ -65,14 +65,21 @@ Build-Depends: cairo, gtk, + containers >= 0.2 && < 0.5, iteratee >= 0.8.6.0 && < 0.9, MonadCatchIO-transformers > 0.2 && < 0.3, mtl >= 2.0.0.0 && < 3, - zoom-cache >= 0.9.1.0 && < 0.10 + mwc-random, + old-locale, + time, + zoom-cache >= 1.0.0.0 && < 1.1.0.0 Exposed-modules: - Scope.View + Scope.Cairo + Scope.Layer + Scope.Plot Scope.Types + Scope.View Executable scope if flag(splitBase) @@ -88,15 +95,17 @@ Hs-Source-Dirs: ., src Build-Depends: cairo, - containers >= 0.2 && < 0.5, glib, gtk, + containers >= 0.2 && < 0.5, iteratee >= 0.8.6.0 && < 0.9, ListLike >= 1.0 && < 4, MonadCatchIO-transformers > 0.2 && < 0.3, mtl >= 2.0.0.0 && < 3, mwc-random, - zoom-cache >= 0.9.1.0 && < 0.10 + old-locale, + time, + zoom-cache >= 1.0.0.0 && < 1.1.0.0 ------------------------------------------------------------------------ -- Git repo diff --git a/src/GUI.hs b/src/GUI.hs --- a/src/GUI.hs +++ b/src/GUI.hs @@ -1,39 +1,30 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -- TimeStampable -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# OPTIONS -Wall -fno-warn-unused-do-bind -fno-warn-orphans #-} +{-# OPTIONS -Wall -fno-warn-unused-do-bind #-} module GUI ( guiMain ) where -import Prelude hiding (catch) - import Control.Applicative ((<$>)) import Control.Concurrent -import Control.Monad.CatchIO import Control.Monad.Reader -import Data.Function (on) -import qualified Data.IntMap as IM import Data.IORef -import Data.List (groupBy) import Data.Maybe -import qualified Data.Iteratee as I -import Data.ZoomCache.Multichannel -import Data.ZoomCache.Numeric +import Data.Time (UTCTime, formatTime) +import Data.ZoomCache (TimeStamp(..), prettyTimeStamp) import qualified Graphics.UI.Gtk as G import qualified Graphics.Rendering.Cairo as C -import Graphics.Rendering.Cairo.Internal (Render(..)) -import Graphics.Rendering.Cairo.Types (Cairo) import qualified Graphics.Rendering.Cairo.Matrix as M -import qualified System.Random.MWC as MWC +import System.Locale (defaultTimeLocale) import Paths_scope as My -import Scope.View +import Scope.Layer import Scope.Types +import Scope.View +import Scope.Cairo + ---------------------------------------------------------------------- windowWidth, windowHeight :: Int @@ -122,7 +113,7 @@ adj <- G.adjustmentNew (0.0) (0.0) (1.0) (0.1) 1.0 1.0 drawingArea <- G.drawingAreaNew - let scope = scopeNew drawingArea adj + let scope = scopeCairoNew drawingArea adj scopeRef <- newIORef scope mapM_ (modifyIORefM scopeRef . addLayersFromFile) args @@ -174,7 +165,7 @@ myNew :: IO () myNew = putStrLn "New" -myFileOpen :: IORef Scope -> G.FileChooserDialog -> G.ResponseId -> IO () +myFileOpen :: IORef (Scope ViewCairo) -> G.FileChooserDialog -> G.ResponseId -> IO () myFileOpen scopeRef fcdialog response = do case response of G.ResponseAccept -> do @@ -183,7 +174,7 @@ _ -> return () G.widgetHide fcdialog -myFileSave :: IORef Scope -> G.FileChooserDialog -> G.ResponseId -> IO () +myFileSave :: IORef (Scope ViewCairo) -> G.FileChooserDialog -> G.ResponseId -> IO () myFileSave scopeRef fcdialog response = do case response of G.ResponseAccept -> do @@ -204,19 +195,19 @@ myDelete :: IO () myDelete = putStrLn "Delete" -updateCanvas :: IORef Scope -> IO Bool +updateCanvas :: IORef (Scope ViewCairo) -> IO Bool updateCanvas ref = do scope <- readIORef ref - let c = canvas . view $ scope + let c = canvas . viewUI . view $ scope win <- G.widgetGetDrawWindow c (width, height) <- G.widgetGetSize c G.renderWithDrawable win $ plotWindow width height scope return True -writePng :: FilePath -> IORef Scope -> IO () +writePng :: FilePath -> IORef (Scope ViewCairo) -> IO () writePng path ref = do scope <- readIORef ref - let c = canvas . view $ scope + let c = canvas . viewUI . view $ scope (width, height) <- G.widgetGetSize c C.withImageSurface C.FormatARGB32 width height $ \ result -> do C.renderWith result $ plotWindow width height scope @@ -224,52 +215,26 @@ ---------------------------------------------------------------- -scopeAlign :: IORef Scope -> CanvasX -> DataX -> IO () -scopeAlign ref cx dx = scopeModifyUpdate ref (scopeModifyView (viewAlign cx dx)) - -scopeMoveLeft :: IORef Scope -> IO () -scopeMoveLeft ref = do - scope <- readIORef ref - let View{..} = view scope - scopeAlign ref (CanvasX 0.0) viewX2 - -scopeMoveRight :: IORef Scope -> IO () -scopeMoveRight ref = do - scope <- readIORef ref - let View{..} = view scope - scopeAlign ref (CanvasX 1.0) viewX1 - ----------------------------------------------------------------- - -scopeZoomIn :: IORef Scope -> Double -> IO () -scopeZoomIn ref = scopeZoomInOn ref (CanvasX 0.5) - -scopeZoomOut :: IORef Scope -> Double -> IO () -scopeZoomOut ref = scopeZoomOutOn ref (CanvasX 0.5) - -scopeZoomInOn :: IORef Scope -> CanvasX -> Double -> IO () -scopeZoomInOn ref focus mult = scopeZoomOutOn ref focus (1.0/mult) - -scopeZoomOutOn :: IORef Scope -> CanvasX -> Double -> IO () -scopeZoomOutOn ref focus mult = - scopeModifyUpdate ref (scopeModifyView (viewZoomOutOn focus mult)) - -scopeModifyMUpdate :: IORef Scope -> (Scope -> IO Scope) -> IO () +scopeModifyMUpdate :: IORef (Scope ViewCairo) + -> (Scope ViewCairo -> IO (Scope ViewCairo)) + -> IO () scopeModifyMUpdate ref f = do modifyIORefM ref f - View{..} <- view <$> readIORef ref - G.adjustmentSetValue adj (toDouble viewX1) - G.adjustmentSetPageSize adj $ toDouble (distance viewX1 viewX2) - G.widgetQueueDraw canvas + viewCairoUpdate =<< view <$> readIORef ref -scopeModifyUpdate :: IORef Scope -> (Scope -> Scope) -> IO () +scopeModifyUpdate :: IORef (Scope ViewCairo) + -> (View ViewCairo -> View ViewCairo) + -> IO () scopeModifyUpdate ref f = do - modifyIORef ref f - View{..} <- view <$> readIORef ref - G.adjustmentSetValue adj (toDouble viewX1) - G.adjustmentSetPageSize adj $ toDouble (distance viewX1 viewX2) - G.widgetQueueDraw canvas + modifyIORef ref (scopeModifyView f) + viewCairoUpdate =<< view <$> readIORef ref +viewCairoUpdate :: View ViewCairo -> IO () +viewCairoUpdate View{..} = do + G.adjustmentSetValue (adj viewUI) (toDouble viewX1) + G.adjustmentSetPageSize (adj viewUI) $ toDouble (distance viewX1 viewX2) + G.widgetQueueDraw (canvas viewUI) + ---------------------------------------------------------------- _canvasToScreen :: G.DrawingArea -> CanvasX -> IO ScreenX @@ -277,49 +242,49 @@ (width, _height) <- G.widgetGetSize c return $ ScreenX (fromIntegral width * cX) -screenToCanvas :: G.DrawingArea -> ScreenX -> IO CanvasX -screenToCanvas c (ScreenX sX) = do - (width, _height) <- G.widgetGetSize c +screenToCanvas :: ViewCairo -> ScreenX -> IO CanvasX +screenToCanvas vc (ScreenX sX) = do + (width, _height) <- G.widgetGetSize (canvas vc) return $ CanvasX (sX / fromIntegral width) ---------------------------------------------------------------- -buttonDown :: IORef Scope -> G.EventM G.EButton () +buttonDown :: IORef (Scope ViewCairo) -> G.EventM G.EButton () buttonDown ref = do (x, _y) <- G.eventCoordinates liftIO $ do - c <- canvas . view <$> readIORef ref - cX <- screenToCanvas c (ScreenX x) - modifyIORef ref (scopeModifyView (viewButtonDown cX)) + vc <- viewUI . view <$> readIORef ref + cX <- screenToCanvas vc (ScreenX x) + scopeModifyUpdate ref (viewButtonDown cX) -buttonRelease :: IORef Scope -> G.EventM G.EButton () +buttonRelease :: IORef (Scope ViewCairo) -> G.EventM G.EButton () buttonRelease ref = liftIO $ modifyIORef ref (scopeModifyView viewButtonRelease) -motion :: IORef Scope -> G.EventM G.EMotion () +motion :: IORef (Scope ViewCairo) -> G.EventM G.EMotion () motion ref = do (x, _y) <- G.eventCoordinates liftIO $ do View{..} <- view <$> readIORef ref - cX <- screenToCanvas canvas (ScreenX x) - scopeModifyUpdate ref $ scopeModifyView (viewButtonMotion cX) + cX <- screenToCanvas viewUI (ScreenX x) + scopeModifyUpdate ref (viewButtonMotion cX) -wheel :: IORef Scope -> G.EventM G.EScroll () +wheel :: IORef (Scope ViewCairo) -> G.EventM G.EScroll () wheel ref = do (x, _y) <- G.eventCoordinates dir <- G.eventScrollDirection liftIO $ do scope <- readIORef ref let View{..} = view scope - cX <- screenToCanvas canvas (ScreenX x) + cX <- screenToCanvas viewUI (ScreenX x) case dir of - G.ScrollUp -> scopeZoomInOn ref cX 1.2 - G.ScrollDown -> scopeZoomOutOn ref cX 1.2 + G.ScrollUp -> scopeModifyUpdate ref (viewZoomInOn cX 1.2) + G.ScrollDown -> scopeModifyUpdate ref (viewZoomOutOn cX 1.2) _ -> return () -scroll :: IORef Scope -> IO () +scroll :: IORef (Scope ViewCairo) -> IO () scroll ref = do - val <- G.adjustmentGetValue =<< adj . view <$> readIORef ref - scopeModifyUpdate ref $ scopeModifyView (viewMoveTo val) + val <- G.adjustmentGetValue =<< adj . viewUI . view <$> readIORef ref + scopeModifyUpdate ref (viewMoveTo val) ---------------------------------------------------------------- @@ -334,50 +299,37 @@ #define XK_Page_Down 0xff56 #define XK_End 0xff57 /* EOL */ -keyDown :: IORef Scope -> G.EventM G.EKey () +keyDown :: IORef (Scope ViewCairo) -> G.EventM G.EKey () keyDown ref = do v <- G.eventKeyVal -- n <- G.eventKeyName -- liftIO . putStrLn $ printf "Key %s (%d) pressed" n v - liftIO $ case v of - XK_Home -> scopeAlign ref (CanvasX 0.0) (DataX 0.0) - XK_End -> scopeAlign ref (CanvasX 1.0) (DataX 1.0) - XK_Up -> scopeZoomIn ref 2.0 - XK_Down -> scopeZoomOut ref 2.0 - XK_Left -> scopeMoveRight ref - XK_Right -> scopeMoveLeft ref - _ -> return () - ----------------------------------------------------------------- - -foreach :: (Monad m) => [a] -> (a -> m b) -> m [b] -foreach = flip mapM + let f = case v of + XK_Home -> Just viewMoveStart + XK_End -> Just viewMoveEnd + XK_Up -> Just $ viewZoomIn 2.0 + XK_Down -> Just $ viewZoomOut 2.0 + XK_Left -> Just viewMoveRight + XK_Right -> Just viewMoveLeft + _ -> Nothing -keepState :: C.Render t -> C.Render () -keepState render = do - C.save - _ <- render - C.restore + maybe (return ()) (liftIO . scopeModifyUpdate ref) f ---------------------------------------------------------------- -plotWindow :: Int -> Int -> Scope -> C.Render () +plotWindow :: Int -> Int -> Scope ViewCairo -> C.Render () plotWindow width height scope = do - prologue width height (view scope) + prologue width height plotLayers scope plotTimeline scope plotCursor scope -- Set up stuff -prologue :: Int -> Int -> View -> C.Render () -prologue wWidth wHeight View{..} = do +prologue :: Int -> Int -> C.Render () +prologue wWidth wHeight = do -- Define viewport coords as (-1.0, -1.0) - (1.0, 1.0) let width = 1.0 height = 2.0 - xmax = 1.0 - xmin = 0.0 - ymax = 1.0 - ymin = -1.0 scaleX = realToFrac wWidth / width scaleY = realToFrac wHeight / height @@ -395,48 +347,9 @@ let flipY = M.Matrix 1 0 0 (-1) 0 0 C.transform flipY - grid xmin xmax ymin ymax - - --- Grid and axes -grid :: Double -> Double -> Double -> Double -> C.Render () -grid xmin xmax ymin ymax = - keepState $ do - C.setSourceRGBA 0 0 0 0.7 - -- axes - C.moveTo 0 ymin; C.lineTo 0 ymax; C.stroke - C.moveTo xmin 0; C.lineTo xmax 0; C.stroke - -- grid - C.setDash [0.01, 0.99] 0 - foreach [xmin .. xmax] $ \ x -> - do C.moveTo x ymin - C.lineTo x ymax - C.stroke - ----------------------------------------------------------------- - -instance MonadCatchIO C.Render where - m `catch` f = mapRender (\m' -> m' `catch` \e -> runRender $ f e) m - block = mapRender block - unblock = mapRender unblock - -mapRender :: (ReaderT Cairo IO m1 -> ReaderT Cairo IO m) -> Render m1 -> Render m -mapRender f = Render . f . runRender - ----------------------------------------------------------------- - -class TimeStampable a where - timeStamp :: a -> TimeStamp - -instance TimeStampable (TimeStamp, a) where - timeStamp (ts, _) = ts - -instance TimeStampable (Summary a) where - timeStamp = summaryEntry - ----------------------------------------------------------------- +---------------------------------------------------------------------- -plotCursor :: Scope -> C.Render () +plotCursor :: Scope ViewCairo -> C.Render () plotCursor scope = maybe (return ()) f pointerX where View{..} = view scope @@ -447,20 +360,36 @@ C.lineTo cX 1.0 C.stroke ----------------------------------------------------------------- +---------------------------------------------------------------------- -plotTimeline :: Scope -> C.Render () +class Coordinate a => Timelineable a where + timeLabel :: a -> String + toCanvas :: Scope ui -> a -> CanvasX + +instance Timelineable TimeStamp where + timeLabel = prettyTimeStamp + toCanvas = timeStampToCanvas + +instance Timelineable UTCTime where + timeLabel = formatTime defaultTimeLocale "%Y-%m-%d %T" + toCanvas = utcToCanvas + +plotTimeline :: Scope ViewCairo -> C.Render () plotTimeline scope = do - case (dataToTimeStamp scope viewX1, dataToTimeStamp scope viewX2) of + case (dataToUTC scope viewX1, dataToUTC scope viewX2) of (Just s, Just e) -> do plotAllTicks s e plotAllLabels s e - _ -> return () + _ -> case (dataToTimeStamp scope viewX1, dataToTimeStamp scope viewX2) of + (Just s, Just e) -> do + plotAllTicks s e + plotAllLabels s e + _ -> return () maybe (return ()) plotArrow pointerX where View{..} = view scope - plotAllTicks :: TimeStamp -> TimeStamp -> C.Render () + plotAllTicks :: Timelineable a => a -> a -> C.Render () plotAllTicks s e = do plotTicks 0.001 0.05 s e plotTicks 0.01 0.1 s e @@ -470,40 +399,47 @@ plotTicks 0.08 60.0 s e plotTicks 0.10 3600.0 s e - plotTicks :: Double -> Double -> TimeStamp -> TimeStamp -> C.Render () - plotTicks len step (TS start) (TS end) = - when doDraw $ mapM_ (plotTick len) (map TS [s, s+step .. end]) + plotTicks :: Timelineable a => Double -> Double -> a -> a -> C.Render () + plotTicks len step start end = + when doDraw $ mapM_ (plotTick len start) (map fromDouble [s, s+step .. end']) where - doDraw = (end - start) / step < 100 - s = (fromIntegral (floor (start/step) :: Integer)) * step + doDraw = (end' - start') / step < 100 + s = (fromIntegral (floor (start'/step) :: Integer)) * step + start' = toDouble start + end' = toDouble end - plotTick :: Double -> TimeStamp -> C.Render () - plotTick len ts = do - let (CanvasX cX) = timeStampToCanvas scope ts + plotTick :: Timelineable a => Double -> a -> a -> C.Render () + plotTick len _unify ts = do + let (CanvasX cX) = toCanvas scope ts C.setSourceRGBA 0 0 0 1.0 C.moveTo cX 0.90 C.lineTo cX (0.90 + len) C.stroke - plotAllLabels :: TimeStamp -> TimeStamp -> C.Render () - plotAllLabels (TS start) (TS end) = - mapM_ (\s -> plotLabels s (TS start) (TS end)) steps + plotAllLabels :: Timelineable a => a -> a -> C.Render () + plotAllLabels start end = + mapM_ (\s -> plotLabels s start end) steps where - readable x = let viz = (end - start) / x in (viz < 5 && viz >= 1) + readable x = let viz = (end' - start') / x in (viz < 5 && viz >= 1) steps = take 1 . filter readable $ [3600, 60, 10, 5, 1, 0.1, 0.05] + start' = toDouble start + end' = toDouble end - plotLabels :: Double -> TimeStamp -> TimeStamp -> C.Render () - plotLabels step (TS start) (TS end) = keepState $ do + plotLabels :: Timelineable a => Double -> a -> a -> C.Render () + plotLabels step start end = keepState $ do let flipY = M.Matrix 1 0 0 (-2.2) 0 0 C.transform flipY - let s = (fromIntegral (floor (start/step) :: Integer)) * step - mapM_ (plotLabel . TS) [s, s+step .. end] + let s = (fromIntegral (floor (start'/step) :: Integer)) * step + mapM_ (plotLabel start . fromDouble) [s, s+step .. end'] + where + start' = toDouble start + end' = toDouble end - plotLabel :: TimeStamp -> C.Render () - plotLabel ts = do - let CanvasX cX = timeStampToCanvas scope ts - drawString (prettyTimeStamp ts) cX (-0.44) + plotLabel :: Timelineable a => a -> a -> C.Render () + plotLabel _unify ts = do + let CanvasX cX = toCanvas scope ts + drawString (timeLabel ts) cX (-0.44) drawString :: String -> Double -> Double -> C.Render () drawString s x y = do @@ -521,230 +457,11 @@ C.lineTo cX (0.98) C.fill ----------------------------------------------------------------- - -plotLayers :: Scope -> C.Render () -plotLayers scope = mapM_ f layersByFile - where - f :: [ScopeLayer] -> C.Render () - f ls = keepState $ plotFileLayers (fn . head $ ls) ls scope - layersByFile = groupBy ((==) `on` fn) (layers scope) - fn (ScopeLayer l) = filename l - -plotFileLayers :: FilePath -> [ScopeLayer] -> Scope -> C.Render () -plotFileLayers path layers scope = - flip I.fileDriverRandom path $ do - I.joinI $ enumCacheFile identifiers $ do - seekTimeStamp (viewStartTime scope (view scope)) - I.joinI . (I.takeWhileE (before (viewEndTime scope v)) >=> I.take 1) $ I.sequence_ is - where - v = view scope - identifiers = standardIdentifiers - is = map (plotLayer scope) layers - -plotLayer :: Scope -> ScopeLayer -> I.Iteratee [Stream] Render () -plotLayer scope (ScopeLayer Layer{..}) = - I.joinI . filterTracks [trackNo] . I.joinI . convEnee $ render plotter - where - render (LayerMap f) = do - d0'm <- I.tryHead - case d0'm of - Just d0 -> I.foldM renderMap (toX d0) >> return () - Nothing -> return () - where - renderMap x0 d = do - let x = toX d - f x0 (x-x0) d - return x - render (LayerFold f b00) = do - d0'm <- I.tryHead - case d0'm of - Just d0 -> I.foldM renderFold (toX d0, b00) >> return () - Nothing -> return () - where - renderFold (x0, b0) d = do - let x = toX d - b <- f x0 (x-x0) b0 d - return (x, b) - - toX :: Timestampable a => a -> Double - toX = toDouble . timeStampToCanvas scope . fromJust . timestamp - ---------------------------------------------------------------------- --- Raw data -_plotRaw :: Double -> LayerFoldFunc (TimeStamp, Double) (Maybe Double) -_plotRaw yR = plotRaw1 (\y -> y * 2.0 / yR) - -plotRawList :: Double -> LayerFoldFunc (TimeStamp, [Double]) (Maybe [Double]) -plotRawList yRange x w Nothing (ts, ys) = plotRawList yRange x w (Just ys) (ts, ys) -plotRawList yRange x w (Just ys0) (ts, ys) = - Just <$> mapM f (zip3 (map yFunc [0..]) ys0 ys) - where - l = length ys - yStep = 2.0 / fromIntegral l - yFunc n v = (-1.0) + (n * yStep) + ((0.5) * yStep) + (v * yStep / yRange) - f :: ((Double -> Double), Double, Double) -> C.Render Double - f (y, s0, s) = fromJust <$> plotRaw1 y x w (Just s0) (ts, s) - -plotRaw1 :: (Double -> Double) -> LayerFoldFunc (TimeStamp, Double) (Maybe Double) -plotRaw1 f x w Nothing (ts, y) = plotRaw1 f x w (Just y) (ts, y) -plotRaw1 f x w (Just y0) (_ts, y) = do - let y' = f y - C.moveTo x y0 - C.lineTo (x+w) y' - C.stroke - return (Just y') - ----------------------------------------------------------------------- --- Summary data - -_plotSummary :: Double -> Double -> Double -> Double - -> LayerFoldFunc (Summary Double) (Maybe (Summary Double)) -_plotSummary dYRange = plotSummary1 (\v -> v * 4.0 / dYRange) - -plotSummaryList :: Double -> Double -> Double -> Double - -> LayerFoldFunc [Summary Double] (Maybe [Summary Double]) -plotSummaryList dYRange r g b x w Nothing ss = - plotSummaryList dYRange r g b x w (Just ss) ss -plotSummaryList dYRange r g b x w (Just ss0) ss = do - Just <$> mapM f (zip3 (map yFunc [0..]) ss0 ss) - where - l = length ss - yStep = 2.0 / fromIntegral l - yFunc n v = (-1.0) + (n * yStep) + ((0.5) * yStep) + (v * yStep / dYRange) - f :: ((Double -> Double), Summary Double, Summary Double) -> C.Render (Summary Double) - f (y, s0, s) = fromJust <$> plotSummary1 y r g b x w (Just s0) s - --- | Plot one numeric summary -plotSummary1 :: (Double -> Double) -> Double -> Double -> Double - -> LayerFoldFunc (Summary Double) (Maybe (Summary Double)) -plotSummary1 y r g b x w Nothing s = - plotSummary1 y r g b x w (Just s) s -plotSummary1 y r g b x w (Just s0) s = do - C.setSourceRGBA r g b 0.3 - C.moveTo x (y (numMax sd0)) - C.lineTo (x+w) (y (numMax sd)) - C.lineTo (x+w) (y (numMin sd)) - C.lineTo x (y (numMin sd0)) - C.fill - - C.setSourceRGB (r*0.6) (g*0.6) (b*0.6) - C.moveTo x (y (numAvg sd0)) - C.lineTo (x+w) (y (numAvg sd)) - C.stroke - return (Just s) - where - sd0 = summaryData s0 - sd = summaryData s - ----------------------------------------------------------------------- - -scopeModifyView :: (View -> View) -> Scope -> Scope -scopeModifyView f scope = scope{ view = f (view scope) } - ----------------------------------------------------------------------- --- Random, similar colors - -type RGB = (Double, Double, Double) - -genColor :: RGB -> Double -> MWC.GenIO -> IO RGB -genColor (r, g, b) a gen = do - let a' = 1.0 - a - r' <- MWC.uniformR (0.0, a') gen - g' <- MWC.uniformR (0.0, a') gen - b' <- MWC.uniformR (0.0, a') gen - return (r*a + r', g*a + g', b*a * b') - -genColors :: Int -> RGB -> Double -> IO [RGB] -genColors n rgb a = MWC.withSystemRandom (replicateM n . genColor rgb a) - ----------------------------------------------------------------------- - -layersFromFile :: FilePath -> IO ([ScopeLayer], Maybe (TimeStamp, TimeStamp)) -layersFromFile path = do - tracks <- IM.keys . cfSpecs <$> I.fileDriverRandom (iterHeaders standardIdentifiers) path - colors <- genColors (length tracks) (0.9, 0.9, 0.9) (0.5) - -- foldl1 merge <$> mapM (\t -> I.fileDriverRandom (iterLayers t) path) (zip tracks colors) - foldl1 merge <$> mapM (\t -> I.fileDriverRandom (iterListLayers t) path) (zip tracks colors) - where - merge :: ([ScopeLayer], Maybe (TimeStamp, TimeStamp)) - -> ([ScopeLayer], Maybe (TimeStamp, TimeStamp)) - -> ([ScopeLayer], Maybe (TimeStamp, TimeStamp)) - merge (ls1, bs1) (ls2, bs2) = (ls1 ++ ls2, unionBounds bs1 bs2) - -{- - iterLayers (trackNo, color) = layers trackNo color <$> - wholeTrackSummaryListDouble standardIdentifiers trackNo - - layers :: TrackNo -> RGB -> Summary Double -> ([ScopeLayer], Maybe (TimeStamp, TimeStamp)) - layers trackNo rgb s = ([ ScopeLayer (rawLayer trackNo s) - , ScopeLayer (sLayer trackNo rgb s) - ] - , Just (summaryEntry s, summaryExit s)) - - rawLayer :: TrackNo -> Summary Double -> Layer (TimeStamp, Double) - rawLayer trackNo s = Layer path trackNo (summaryEntry s) (summaryExit s) - enumDouble (LayerFold (plotRaw (yRange s)) Nothing) - - sLayer :: TrackNo -> RGB -> Summary Double -> Layer (Summary Double) - sLayer trackNo (r, g, b) s = Layer path trackNo (summaryEntry s) (summaryExit s) - (enumSummaryDouble 1) (LayerFold (plotSummary (yRange s) r g b) Nothing) --} - - iterListLayers (trackNo, color) = listLayers trackNo color <$> - wholeTrackSummaryListDouble standardIdentifiers trackNo - - listLayers :: TrackNo -> RGB -> [Summary Double] -> ([ScopeLayer], Maybe (TimeStamp, TimeStamp)) - listLayers trackNo rgb ss = ([ ScopeLayer (rawListLayer trackNo ss) - , ScopeLayer (sListLayer trackNo rgb ss) - ] - , Just (summaryEntry s, summaryExit s)) - where - s = head ss - - rawListLayer :: TrackNo -> [Summary Double] -> Layer (TimeStamp, [Double]) - rawListLayer trackNo ss = Layer path trackNo (summaryEntry s) (summaryExit s) - enumListDouble (LayerFold (plotRawList (maxRange ss)) Nothing) - where - s = head ss - - sListLayer :: TrackNo -> RGB -> [Summary Double] -> Layer [Summary Double] - sListLayer trackNo (r, g, b) ss = Layer path trackNo (summaryEntry s) (summaryExit s) - (enumSummaryListDouble 1) (LayerFold (plotSummaryList (maxRange ss) r g b) Nothing) - where - s = head ss - - maxRange :: [Summary Double] -> Double - maxRange = maximum . map yRange - - yRange :: Summary Double -> Double - yRange s = 2 * ((abs . numMin . summaryData $ s) + (abs . numMax . summaryData $ s)) - -unionBounds :: Ord a => Maybe (a, a) -> Maybe (a, a) -> Maybe (a, a) -unionBounds a Nothing = a -unionBounds Nothing b = b -unionBounds (Just r1) (Just r2) = Just (unionRange r1 r2) - -addLayersFromFile :: FilePath -> Scope -> IO Scope -addLayersFromFile path scope = do - (newLayers, newBounds) <- layersFromFile path - let oldBounds = bounds scope - mb = unionBounds oldBounds newBounds - t = case oldBounds of - Just ob -> if oldBounds == mb - then id - else scopeTransform (mkTSDataTransform ob (fromJust mb)) - _ -> id - return $ (t scope) { layers = layers scope ++ newLayers - , bounds = mb - } - modifyIORefM :: IORef a -> (a -> IO a) -> IO () modifyIORefM ref f = do x <- readIORef ref x' <- f x writeIORef ref x' - -----------------------------------------------------------------