scope (empty) → 0.5.0.0
raw patch · 13 files changed
+1056/−0 lines, 13 filesdep +MonadCatchIO-transformersdep +basedep +cairosetup-changedbinary-added
Dependencies added: MonadCatchIO-transformers, base, cairo, containers, glib, gtk, iteratee, mtl, mwc-random, zoom-cache
Files
- LICENSE +27/−0
- Scope/Types.hs +192/−0
- Scope/View.hs +73/−0
- Setup.hs +3/−0
- data/actions.ui +22/−0
- demo/demo1.zoom binary
- demo/demo2.zoom binary
- demo/demo3.zoom binary
- demo/demo4.zoom binary
- scope.cabal +105/−0
- src/Children.hs +28/−0
- src/GUI.hs +577/−0
- src/main.hs +29/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Conrad Parker 2006++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ Scope/Types.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+{- |+ Module : Scope.Types+ Copyright : Conrad Parker+ License : BSD3-style (see LICENSE)++ Maintainer : Conrad Parker <conrad@metadecks.org>+ Stability : unstable+ Portability : unknown++ Scope types and interfaces++ The coordinate system:++@+ CanvasX 0.0 CanvasX 1.0 DataX 1.0+ | | |+ DataX 0.0 V V V+ |+ V --------------------------------- <- CanvasY -1.0+ | |+ +---------+---------------------------------+--------------++ | | | |+ | | | |+ +---------+---------------------------------+--------------++ | |+ --------------------------------- <- CanvasY -1.0+@++-}+----------------------------------------------------------------------++module Scope.Types (+ -- * Coordinates+ Coordinate(..)+ , ScreenX(..)+ , ScreenY(..)+ , CanvasX(..)+ , CanvasY(..)+ , DataX(..)+ , DataY(..)++ , restrictPair+ , restrictPair01+ , translatePair+ , zoomPair++ -- * Scope+ , Scope(..)+ , scopeNew++ -- * Views+ , View(..)++ -- * Layers+ , Layer(..)+ , LayerPlot(..)+ , LayerMapFunc+ , LayerFoldFunc+ , ScopeLayer(..)+) where++import Data.Maybe+import Data.Iteratee (Enumeratee)+import Data.ZoomCache++import qualified Graphics.Rendering.Cairo as C+import qualified Graphics.UI.Gtk as G++----------------------------------------------------------------------++class Coordinate a where+ fromDouble :: Double -> a+ toDouble :: a -> Double++ -- | Distance from to+ distance :: a -> a -> a+ -- | Translate x by+ translate :: a -> a -> a++newtype ScreenX = ScreenX Double deriving (Eq, Ord, Show)+newtype ScreenY = ScreenY Double deriving (Eq, Ord, Show)+newtype CanvasX = CanvasX Double deriving (Eq, Ord, Show)+newtype CanvasY = CanvasY Double deriving (Eq, Ord, Show)+newtype DataX = DataX Double deriving (Eq, Ord, Show)+newtype DataY = DataY Double deriving (Eq, Ord, Show)++instance Coordinate Double where+ fromDouble = id+ toDouble = id+ distance x1 x2 = x2 - x1+ translate t x = x + t++instance Coordinate ScreenX where+ fromDouble d = ScreenX d+ toDouble (ScreenX d) = d+ distance (ScreenX x1) (ScreenX x2) = ScreenX (distance x1 x2)+ translate (ScreenX t) (ScreenX x) = ScreenX (translate t x)++instance Coordinate CanvasX where+ fromDouble d = CanvasX d+ toDouble (CanvasX d) = d+ distance (CanvasX x1) (CanvasX x2) = CanvasX (distance x1 x2)+ translate (CanvasX t) (CanvasX x) = CanvasX (translate t x)++instance Coordinate DataX where+ fromDouble d = DataX d+ toDouble (DataX d) = d+ distance (DataX x1) (DataX x2) = DataX (distance x1 x2)+ translate (DataX t) (DataX x) = DataX (translate t x)++translatePair :: Coordinate a => a -> (a, a) -> (a, a)+translatePair t (x1, x2) = (translate t x1, translate t x2)++-- | Restrict a window to within a given range+restrictPair :: (Ord a, Coordinate a) => (a, a) -> (a, a) -> (a, a)+restrictPair (rangeX1, rangeX2) (x1, x2)+ | w >= rW = (rangeX1, rangeX2)+ | x1 < rangeX1 = (rangeX1, translate rangeX1 w)+ | x2 > rangeX2 = (x1', rangeX2)+ | otherwise = (x1, x2)+ where+ rW = distance rangeX1 rangeX2+ w = distance x1 x2+ x1' = distance w rangeX2++restrictPair01 :: (Ord a, Coordinate a) => (a, a) -> (a, a)+restrictPair01 = restrictPair (fromDouble 0.0, fromDouble 1.0)++zoomPair :: Coordinate a => CanvasX -> Double -> (a, a) -> (a, a)+zoomPair (CanvasX focus) mult (x1, x2) = (translate off1 x1, translate off2 x2)+ where+ off1 = fromDouble $ (oldW - newW) * focus+ off2 = fromDouble $ (newW - oldW) * (1.0 - focus)+ oldW = toDouble $ distance x1 x2+ newW = min 1.0 (oldW * mult)++----------------------------------------------------------------------++-- | 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 ()++-- | 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++data LayerPlot a = LayerMap (LayerMapFunc a)+ | forall b . LayerFold (LayerFoldFunc a b) b++data Layer a = Layer+ { filename :: FilePath+ , trackNo :: TrackNo+ , dataLength :: Int+ , convEnee :: Enumeratee [Stream] [a] C.Render ()+ , plotter :: LayerPlot a+ }++data ScopeLayer = forall a . ScopeLayer (Layer a)++----------------------------------------------------------------------++data Scope = Scope+ { view :: View+ , layers :: [ScopeLayer]+ }++data View = View+ { canvas :: G.DrawingArea+ , adj :: G.Adjustment+ , viewX1 :: DataX+ , viewY1 :: Double+ , viewX2 :: DataX+ , viewY2 :: Double+ , dragDX :: Maybe DataX -- DataX of pointer at drag down+ }++scopeNew :: G.DrawingArea -> G.Adjustment -> Scope+scopeNew c adj = Scope {+ view = viewInit c adj+ , layers = []+ }++viewInit :: G.DrawingArea -> G.Adjustment -> View+viewInit c adj = View c adj (DataX 0.0) (-1.0) (DataX 1.0) 1.0 Nothing++----------------------------------------------------------------------
+ Scope/View.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS -Wall #-}+----------------------------------------------------------------------+-- |+-- Module : Scope.View+-- Copyright : Conrad Parker+-- License : BSD3-style (see LICENSE)+--+-- Maintainer : Conrad Parker <conrad@metadecks.org>+-- Stability : unstable+-- Portability : unknown+--+-- Functions for dealing with Views+----------------------------------------------------------------------++module Scope.View (+ -- * Motion, zooming+ viewAlign+ , viewMoveTo+ , viewZoomOutOn++ -- * Button handling+ , viewButtonDown+ , viewButtonMotion+ , viewButtonRelease+) where++import Data.Maybe (fromJust)++import Scope.Types++----------------------------------------------------------------------++canvasToData :: View -> CanvasX -> DataX+canvasToData View{..} (CanvasX cX) = translate viewX1 $+ DataX (cX * toDouble (distance viewX1 viewX2))++viewSetEnds :: DataX -> DataX -> View -> View+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 cx) (DataX dx) v@View{..} = viewSetEnds (DataX newX1') (DataX newX2') v+ where+ DataX vW = distance viewX1 viewX2 -- current width of view window+ newX1 = max 0 $ dx - (cx * vW)+ newX2 = newX1 + vW+ (newX1', newX2') = restrictPair01 (newX1, newX2)++viewMoveTo :: Double -> View -> View+viewMoveTo val v@View{..} = viewSetEnds newX1' newX2' v+ where+ (newX1', newX2') = restrictPair01 .+ translatePair (distance viewX1 (DataX val)) $+ (viewX1, viewX2)++viewZoomOutOn :: CanvasX -> Double -> View -> View+viewZoomOutOn focus mult v@View{..} = viewSetEnds newX1 newX2' v+ where+ (newX1, newX2') = restrictPair01 $+ zoomPair focus mult (viewX1, viewX2)++viewButtonDown :: CanvasX -> View -> View+viewButtonDown cX v = v { dragDX = Just (canvasToData v cX) }++viewButtonMotion :: CanvasX -> View -> View+viewButtonMotion cX v@View{..} = viewAlign cX (fromJust dragDX) v++viewButtonRelease :: View -> View+viewButtonRelease v = v { dragDX = Nothing}++----------------------------------------------------------------------
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ data/actions.ui view
@@ -0,0 +1,22 @@+<ui>+ <menubar name="menubar1">+ <menu action="FMA">+ <menuitem action="NEWA"/>+ <menuitem action="OPENA"/>+ <menuitem action="SAVEA"/>+ <menuitem action="SAVEASA"/>+ <separator/>+ <menuitem action="QUITA"/>+ </menu>+ <menu action="EMA">+ <menuitem action="cut1"/>+ <menuitem action="copy1"/>+ <menuitem action="paste1"/>+ <menuitem action="delete1"/>+ </menu>+ <menu action="VMA"/>+ <menu action="HMA">+ <menuitem action="ABOUTA"/>+ </menu>+ </menubar>+</ui>
+ demo/demo1.zoom view
binary file changed (absent → 111582 bytes)
+ demo/demo2.zoom view
binary file changed (absent → 111582 bytes)
+ demo/demo3.zoom view
binary file changed (absent → 111582 bytes)
+ demo/demo4.zoom view
binary file changed (absent → 111582 bytes)
+ scope.cabal view
@@ -0,0 +1,105 @@+Name: scope++Version: 0.5.0.0++Synopsis: An interactive renderer for plotting time-series data++Description:+ scope is a framework for plotting time-series data, using zoom-cache+ files.+ .+ This version includes a Gtk/Cairo application. It's a desktop+ application with a /File/ menu; remember those? wow! This will probably+ be split out into a separate package later, and there'll be a webby+ javascripty version too, but for now there's this desktop app.+ .+ To run it, simply:+ .+ @+ $ cabal install scope+ $ scope+ @+ .+ Then, select /File->Open/ from the menubar, with your mouse: there's no+ swiping gestures back here, baby! Four (yes, 4) demo files are included+ in this version of the package. Choose one, and it will be drawn in the+ window. Amazing! It should look something like what you saw in the post+ you read about this in, but more personal because now it's happening to+ you.+ .+ Zoom in with the scroll wheel on your mouse. If you don't have a scroll+ wheel, use the Up and Down arrow keys on your keyboard. If you don't have+ up and down arrows /you are elite/!+ .+ Pan around by dragging it. There's a scrollbar too if you're into that.+ .+ Load up another file! It will also be drawn. Zoom in and out and pan+ around, yay! Life is gooood!++License: BSD3+License-file: LICENSE+Author: Conrad Parker+Maintainer: conrad@metadecks.org+Category: Development++Cabal-Version: >= 1.8+Build-type: Simple+Data-Files:+ data/actions.ui+ demo/demo1.zoom+ demo/demo2.zoom+ demo/demo3.zoom+ demo/demo4.zoom++flag splitBase+ description: Use the split-up base package.++Library+ if flag(splitBase)+ build-depends:+ base >= 3 && < 6+ else+ build-depends:+ base < 3++ Build-Depends:+ cairo,+ gtk,+ iteratee >= 0.8.6.0 && < 0.9,+ MonadCatchIO-transformers > 0.2 && < 0.3,+ mtl >= 2.0.0.0 && < 3,+ zoom-cache >= 0.8.1.0 && < 0.9++ Exposed-modules:+ Scope.View+ Scope.Types++Executable scope+ if flag(splitBase)+ build-depends:+ base >= 3 && < 6+ else+ build-depends:+ base < 3++ Main-Is: main.hs+ Other-Modules: Children+ GUI+ Hs-Source-Dirs: ., src+ Build-Depends:+ cairo,+ containers >= 0.2 && < 0.5,+ glib,+ gtk,+ iteratee >= 0.8.6.0 && < 0.9,+ MonadCatchIO-transformers > 0.2 && < 0.3,+ mtl >= 2.0.0.0 && < 3,+ mwc-random,+ zoom-cache >= 0.8.1.0 && < 0.9++------------------------------------------------------------------------+-- Git repo+--+source-repository head+ type: git+ location: git://github.com/kfish/scope.git
+ src/Children.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS -Wall #-}++module Children where++import Control.Concurrent+import Control.Exception (finally)++import System.IO.Unsafe (unsafePerformIO)++children :: MVar [MVar ()]+children = unsafePerformIO (newMVar [])++waitForChildren :: IO ()+waitForChildren = do+ cs <- takeMVar children+ case cs of+ [] -> return ()+ m:ms -> do+ putMVar children ms+ takeMVar m+ waitForChildren++forkChild :: IO () -> IO ThreadId+forkChild io = do+ mvar <- newEmptyMVar+ childs <- takeMVar children+ putMVar children (mvar:childs)+ forkIO (io `finally` putMVar mvar ())
+ src/GUI.hs view
@@ -0,0 +1,577 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS -Wall -fno-warn-unused-do-bind -fno-warn-orphans #-}+--+-- Based on Gtk2Hs/demo/cairo/Drawing2.hs +-- Author: Johan Bockgård <bojohan@dd.chalmers.se>+--+-- This code is in the public domain.+--++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.Numeric+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 Text.Printf++import Paths_scope as My+import Scope.View+import Scope.Types++----------------------------------------------------------------------++windowWidth, windowHeight :: Int+windowWidth = 500+windowHeight = 500++{-+-- Write image to file+_writePng :: IO ()+_writePng =+ C.withImageSurface C.FormatARGB32 width height $ \ result -> do+ C.renderWith result $ plotWindow width height+ C.surfaceWriteToPNG result "Draw.png"+ where width = windowWidth+ height = windowHeight+-}++-- Display image in window+guiMain :: Chan String -> [String] -> IO ()+guiMain chan args = do+ _ <- G.initGUI++ window <- G.windowNew+ G.widgetSetSizeRequest window windowWidth windowHeight+ G.widgetSetAppPaintable window True+ G.widgetSetDoubleBuffered window True++ vbox <- G.vBoxNew False 0+ G.containerAdd window vbox++ ui <- G.uiManagerNew++ filename <- My.getDataFileName "data/actions.ui"+ G.uiManagerAddUiFromFile ui filename++ let getWidget = fmap fromJust . G.uiManagerGetWidget ui++ -- Menubar+ fma <- G.actionNew "FMA" "File" Nothing Nothing+ ema <- G.actionNew "EMA" "Edit" Nothing Nothing+ vma <- G.actionNew "VMA" "View" Nothing Nothing+ hma <- G.actionNew "HMA" "Help" Nothing Nothing++ -- File menu+ newa <- G.actionNew "NEWA" "New" (Just "Just a Stub") (Just G.stockNew)+ newa `G.on` G.actionActivated $ myNew+ opena <- G.actionNew "OPENA" "Open" (Just "Just a Stub") (Just G.stockOpen)+ savea <- G.actionNew "SAVEA" "Save" (Just "Just a Stub") (Just G.stockSave)+ saveasa <- G.actionNew "SAVEASA" "Save As" (Just "Just a Stub") (Just G.stockSaveAs)+ quita <- G.actionNew "QUITA" "Quit" (Just "Just a Stub") (Just G.stockQuit)+ quita `G.on` G.actionActivated $ myQuit window chan++ let fChooser action label = G.fileChooserDialogNew Nothing (Just window) action+ [(G.stockCancel, G.ResponseCancel), (label, G.ResponseAccept)]++ openDialog <- fChooser G.FileChooserActionOpen G.stockOpen+ demoPath <- My.getDataFileName "demo"+ G.fileChooserSetCurrentFolder openDialog demoPath++ opena `G.on` G.actionActivated $ G.widgetShow openDialog++ saveDialog <- fChooser G.FileChooserActionSave G.stockSave+ savea `G.on` G.actionActivated $ G.widgetShow saveDialog+ saveasa `G.on` G.actionActivated $ G.widgetShow saveDialog+ saveDialog `G.on` G.response $ myFileSave saveDialog++ -- Edit menu+ cut1 <- G.actionNew "cut1" "Cut" (Just "Just a Stub") (Just G.stockCut)+ cut1 `G.on` G.actionActivated $ myCut+ copy1 <- G.actionNew "copy1" "Copy" (Just "Just a Stub") (Just G.stockCopy)+ copy1 `G.on` G.actionActivated $ myCopy+ paste1 <- G.actionNew "paste1" "Paste" (Just "Just a Stub") (Just G.stockPaste)+ paste1 `G.on` G.actionActivated $ myPaste+ delete1 <- G.actionNew "delete1" "Delete" (Just "Just a Stub") (Just G.stockDelete)+ delete1 `G.on` G.actionActivated $ myDelete++ -- Help menu+ -- About dialog+ aboutdialog <- G.aboutDialogNew+ abouta <- G.actionNew "ABOUTA" "About" (Just "Just a Stub") Nothing+ abouta `G.on` G.actionActivated $ G.widgetShow aboutdialog+ aboutdialog `G.on` G.response $ const $ G.widgetHide aboutdialog++ -- Action group+ agr <- G.actionGroupNew "AGR"+ mapM_ (G.actionGroupAddAction agr) [fma, ema, vma, hma]+ mapM_ (\act -> G.actionGroupAddActionWithAccel agr act Nothing)+ [ newa, opena, savea, saveasa, quita+ , cut1, copy1, paste1, delete1+ , abouta+ ]++ G.uiManagerInsertActionGroup ui agr 0++ menubar <- getWidget "/ui/menubar1"+ G.boxPackStart vbox menubar G.PackNatural 0++ adj <- G.adjustmentNew (0.0) (0.0) (1.0) (0.1) 1.0 1.0+ drawingArea <- G.drawingAreaNew++ let scope = scopeNew drawingArea adj+ scopeRef <- newIORef scope++ mapM_ (modifyIORefM scopeRef . addLayersFromFile) args+ openDialog `G.on` G.response $ myFileOpen scopeRef openDialog++ adj `G.onValueChanged` (scroll scopeRef)++ G.boxPackStart vbox drawingArea G.PackGrow 0++ drawingArea `G.on` G.buttonPressEvent $ G.tryEvent $ buttonDown scopeRef+ drawingArea `G.on` G.buttonReleaseEvent $ G.tryEvent $ buttonRelease scopeRef+ drawingArea `G.on` G.scrollEvent $ G.tryEvent $ wheel scopeRef+ drawingArea `G.on` G.motionNotifyEvent $ G.tryEvent $ motion scopeRef+ drawingArea `G.on` G.keyPressEvent $ G.tryEvent $ keyDown scopeRef+ G.widgetAddEvents drawingArea+ [ G.KeyPressMask+ , G.KeyReleaseMask+ -- , G.PointerMotionMask+ , G.ButtonMotionMask+ , G.ScrollMask+ ]++ G.widgetSetCanFocus drawingArea True++ drawingArea `G.on` G.exposeEvent $ G.tryEvent $ do+ liftIO $ updateCanvas scopeRef+ return ()++ scrollbar <- G.hScrollbarNew adj+ G.boxPackStart vbox scrollbar G.PackNatural 0++ statusbar <- G.statusbarNew+ G.boxPackStart vbox statusbar G.PackNatural 0++ G.onDestroy window ((myWriteChan chan "quit") >> G.mainQuit)++ G.widgetShowAll window+ G.mainGUI++myQuit :: G.WidgetClass cls => cls -> Chan String -> IO ()+myQuit window chan = do+ G.widgetDestroy window+ myWriteChan chan "quit"++myWriteChan :: Chan String -> String -> IO ()+myWriteChan chan s = do writeChan chan s+ yield+myNew :: IO ()+myNew = putStrLn "New"++myFileOpen :: IORef Scope -> G.FileChooserDialog -> G.ResponseId -> IO ()+myFileOpen scopeRef fcdialog response = do+ case response of+ G.ResponseAccept -> do+ Just filename <- G.fileChooserGetFilename fcdialog+ scopeModifyMRedraw scopeRef (addLayersFromFile filename)+ _ -> return ()+ G.widgetHide fcdialog++myFileSave :: G.FileChooserDialog -> G.ResponseId -> IO ()+myFileSave _ _ = return ()++myCut :: IO ()+myCut = putStrLn "Cut"++myCopy :: IO ()+myCopy = putStrLn "Copy"++myPaste :: IO ()+myPaste = putStrLn "Paste"++myDelete :: IO ()+myDelete = putStrLn "Delete"++updateCanvas :: IORef Scope -> IO Bool+updateCanvas ref = do+ scope <- readIORef ref+ let c = canvas . view $ scope+ win <- G.widgetGetDrawWindow c+ (width, height) <- G.widgetGetSize c+ G.renderWithDrawable win $ plotWindow width height scope+ return True++----------------------------------------------------------------++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))++scopeModifyMRedraw :: IORef Scope -> (Scope -> IO Scope) -> IO ()+scopeModifyMRedraw ref f = do+ modifyIORefM ref f+ G.widgetQueueDraw =<< canvas . view <$> readIORef ref++scopeModifyUpdate :: IORef Scope -> (Scope -> Scope) -> 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++----------------------------------------------------------------++_canvasToScreen :: G.DrawingArea -> CanvasX -> IO ScreenX+_canvasToScreen c (CanvasX cX) = do+ (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+ return $ CanvasX (sX / fromIntegral width)++----------------------------------------------------------------++buttonDown :: IORef Scope -> 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))++buttonRelease :: IORef Scope -> G.EventM G.EButton ()+buttonRelease ref = liftIO $ modifyIORef ref (scopeModifyView viewButtonRelease)++motion :: IORef Scope -> 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)++wheel :: IORef Scope -> 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)+ case dir of+ G.ScrollUp -> scopeZoomInOn ref cX 1.2+ G.ScrollDown -> scopeZoomOutOn ref cX 1.2+ _ -> return ()++scroll :: IORef Scope -> IO ()+scroll ref = do+ val <- G.adjustmentGetValue =<< adj . view <$> readIORef ref+ scopeModifyUpdate ref $ scopeModifyView (viewMoveTo val)++----------------------------------------------------------------++-- Some keys we are interested in, from:+-- http://cgit.freedesktop.org/xorg/proto/x11proto/plain/keysymdef.h+#define XK_Home 0xff50+#define XK_Left 0xff51 /* Move left, left arrow */+#define XK_Up 0xff52 /* Move up, up arrow */+#define XK_Right 0xff53 /* Move right, right arrow */+#define XK_Down 0xff54 /* Move down, down arrow */+#define XK_Page_Up 0xff55+#define XK_Page_Down 0xff56+#define XK_End 0xff57 /* EOL */++keyDown :: IORef Scope -> 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++keepState :: C.Render t -> C.Render ()+keepState render = do+ C.save+ _ <- render+ C.restore++----------------------------------------------------------------++plotWindow :: Int -> Int -> Scope -> C.Render ()+plotWindow width height scope = do+ prologue width height (view scope)+ plotLayers scope++-- Set up stuff+prologue :: Int -> Int -> View -> C.Render ()+prologue wWidth wHeight View{..} = 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++ -- style and color+ C.setLineCap C.LineCapRound+ C.setLineJoin C.LineJoinRound+ C.setLineWidth $ 1 / max scaleX scaleY+ C.setSourceRGBA 0.5 0.7 0.5 0.5++ -- Set up user coordinates+ C.scale scaleX scaleY+ -- center origin vertically+ C.translate 0 (height / 2)+ -- positive y-axis upwards+ 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++----------------------------------------------------------------++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 =+ I.fileDriverRandom (I.joinI $ enumCacheFile identifiers (I.sequence_ is)) path+ where+ 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 $ foldData+ where+ View{..} = view scope++ foldData = do+ I.drop skipLength+ I.joinI . I.take visibleLength $ render plotter++ render (LayerMap f) = do+ I.foldM renderMap canvasX0+ return ()+ where+ renderMap x d = do+ f x stepWidth d+ return (x + stepWidth)+ render (LayerFold f b00) = do+ I.foldM renderFold (canvasX0, b00)+ return ()+ where+ renderFold (x, b0) d = do+ b <- f x stepWidth b0 d+ return (x + stepWidth, b)++ -- | Canvas X coordinate of first data point+ canvasX0 = (fromIntegral skipLength - skip) * stepWidth++ -- | Count of data points to drop before rendering+ skipLength = floor skip++ -- | DataX coordinate of start of view+ skip = fromIntegral dataLength * toDouble viewX1++ -- | Count of data points visible in view+ visibleLength = ceiling viz + 2++ -- | Canvas x length per data point+ stepWidth = 1.0 / viz++ -- | Fractional number of data points visible in view+ viz = fromIntegral dataLength * toDouble (distance viewX1 viewX2)++----------------------------------------------------------------------+-- Raw data++plotRaw :: Double -> LayerFoldFunc (TimeStamp, Double) (Maybe Double)+plotRaw yR x w Nothing (ts, y) = plotRaw yR x w (Just y) (ts, y)+plotRaw yR x w (Just y0) (_ts, y) = do+ C.moveTo x y0+ C.lineTo (x+w) (y * 2.0 {- (viewY2 v - viewY1 v)-} / yR)+ return (Just y)++----------------------------------------------------------------------+-- Summary data++plotSummary :: Double -> Double -> Double -> Double+ -> LayerFoldFunc (Summary Double) (Maybe (Summary Double))+plotSummary dYRange r g b x w Nothing s =+ plotSummary dYRange r g b x w (Just s) s+plotSummary dYRange 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+ y v = v * 4.0 / dYRange++----------------------------------------------------------------------++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]+layersFromFile path = do+ tracks <- IM.keys . cfSpecs <$> I.fileDriverRandom (iterHeaders standardIdentifiers) path+ colors <- genColors (length tracks) (0.9, 0.9, 0.9) (0.5)+ concat <$> mapM (\t -> I.fileDriverRandom (iterLayers t) path) (zip tracks colors)+ where+ iterLayers (trackNo, color) = layers trackNo color <$>+ wholeTrackSummaryDouble standardIdentifiers trackNo++ layers :: TrackNo -> RGB -> Summary Double -> [ScopeLayer]+ layers trackNo rgb s = [ ScopeLayer (rawLayer trackNo s)+ , ScopeLayer (sLayer trackNo rgb s)+ ]++ rawLayer :: TrackNo -> Summary Double -> Layer (TimeStamp, Double)+ rawLayer trackNo s = Layer path trackNo 5000 enumDouble (LayerFold (plotRaw (yRange s)) Nothing)++ sLayer :: TrackNo -> RGB -> Summary Double -> Layer (Summary Double)+ sLayer trackNo (r, g, b) s = Layer path trackNo 600 (enumSummaryDouble 1)+ (LayerFold (plotSummary (yRange s) r g b) Nothing)++ yRange :: Summary Double -> Double+ yRange s = 2 * ((abs . numMin . summaryData $ s) + (abs . numMax . summaryData $ s))++addLayersFromFile :: FilePath -> Scope -> IO Scope+addLayersFromFile path scope = do+ newLayers <- layersFromFile path+ return $ scope { layers = layers scope ++ newLayers }++modifyIORefM :: IORef a -> (a -> IO a) -> IO ()+modifyIORefM ref f = do+ x <- readIORef ref+ x' <- f x+ writeIORef ref x'++----------------------------------------------------------------+
+ src/main.hs view
@@ -0,0 +1,29 @@+{-# OPTIONS -Wall #-}++module Main where++import Control.Concurrent.Chan+import Control.Monad (when)+import System.Environment (getArgs)++import Children+import GUI++main :: IO ()+main = do+ args <- getArgs+ setupMonitor args++setupMonitor :: [String] -> IO ()+setupMonitor args = later waitForChildren $ do+ chan <- newChan+ _ <- forkChild (guiMain chan args)+ monitor chan+ where+ later x y = y >> x++monitor :: Chan String -> IO()+monitor chan = do+ x <- readChan chan+ -- putStrLn $ "Received message: " ++ x+ when (x /= "quit") $ monitor chan