scope 0.5.2.0 → 0.6.0.0
raw patch · 11 files changed
+673/−439 lines, 11 filesdep +old-localedep +timedep ~zoom-cache
Dependencies added: old-locale, time
Dependency ranges changed: zoom-cache
Files
- Scope/Cairo.hs +76/−0
- Scope/Layer.hs +191/−0
- Scope/Plot.hs +105/−0
- Scope/Types.hs +102/−24
- Scope/View.hs +73/−15
- demo/demo1.zoom binary
- demo/demo2.zoom binary
- demo/demo3.zoom binary
- demo/demo4.zoom binary
- scope.cabal +14/−5
- src/GUI.hs +112/−395
+ Scope/Cairo.hs view
@@ -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+
+ Scope/Layer.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+{- |+ Module : Scope.Layer+ Copyright : Conrad Parker+ License : BSD3-style (see LICENSE)++ Maintainer : Conrad Parker <conrad@metadecks.org>+ 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
+ Scope/Plot.hs view
@@ -0,0 +1,105 @@+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+{- |+ Module : Scope.Plot+ Copyright : Conrad Parker+ License : BSD3-style (see LICENSE)++ Maintainer : Conrad Parker <conrad@metadecks.org>+ 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+
Scope/Types.hs view
@@ -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 ----------------------------------------------------------------------
Scope/View.hs view
@@ -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} ----------------------------------------------------------------------
demo/demo1.zoom view
binary file changed (111605 → 111570 bytes)
demo/demo2.zoom view
binary file changed (111605 → 111570 bytes)
demo/demo3.zoom view
binary file changed (175301 → 175266 bytes)
demo/demo4.zoom view
binary file changed (557477 → 557442 bytes)
scope.cabal view
@@ -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
src/GUI.hs view
@@ -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'------------------------------------------------------------------