diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Scope/Types.hs b/Scope/Types.hs new file mode 100644 --- /dev/null +++ b/Scope/Types.hs @@ -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 + 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 + +---------------------------------------------------------------------- diff --git a/Scope/View.hs b/Scope/View.hs new file mode 100644 --- /dev/null +++ b/Scope/View.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Scope.View +-- Copyright : Conrad Parker +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Conrad Parker +-- 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} + +---------------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/data/actions.ui b/data/actions.ui new file mode 100644 --- /dev/null +++ b/data/actions.ui @@ -0,0 +1,22 @@ + + + + + + + + + + + + + + + + + + + + + + diff --git a/demo/demo1.zoom b/demo/demo1.zoom new file mode 100644 Binary files /dev/null and b/demo/demo1.zoom differ diff --git a/demo/demo2.zoom b/demo/demo2.zoom new file mode 100644 Binary files /dev/null and b/demo/demo2.zoom differ diff --git a/demo/demo3.zoom b/demo/demo3.zoom new file mode 100644 Binary files /dev/null and b/demo/demo3.zoom differ diff --git a/demo/demo4.zoom b/demo/demo4.zoom new file mode 100644 Binary files /dev/null and b/demo/demo4.zoom differ diff --git a/scope.cabal b/scope.cabal new file mode 100644 --- /dev/null +++ b/scope.cabal @@ -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 diff --git a/src/Children.hs b/src/Children.hs new file mode 100644 --- /dev/null +++ b/src/Children.hs @@ -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 ()) diff --git a/src/GUI.hs b/src/GUI.hs new file mode 100644 --- /dev/null +++ b/src/GUI.hs @@ -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 +-- +-- 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' + +---------------------------------------------------------------- + diff --git a/src/main.hs b/src/main.hs new file mode 100644 --- /dev/null +++ b/src/main.hs @@ -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