scope-cairo (empty) → 0.8.0.0
raw patch · 12 files changed
+766/−0 lines, 12 filesdep +MonadCatchIO-transformersdep +basedep +cairosetup-changedbinary-added
Dependencies added: MonadCatchIO-transformers, base, cairo, gtk, mtl, old-locale, scope, time, zoom-cache
Files
- LICENSE +27/−0
- Scope/Cairo.hs +76/−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-cairo.cabal +111/−0
- src/Children.hs +28/−0
- src/GUI.hs +470/−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/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+
+ 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 → 111570 bytes)
+ demo/demo2.zoom view
binary file changed (absent → 111570 bytes)
+ demo/demo3.zoom view
binary file changed (absent → 175266 bytes)
+ demo/demo4.zoom view
binary file changed (absent → 557442 bytes)
+ scope-cairo.cabal view
@@ -0,0 +1,111 @@+Name: scope-cairo++Version: 0.8.0.0++Synopsis: An interactive renderer for plotting time-series data++Description:+ scope-cairo is a Cairo rendering backend for scope, which is a+ a framework for plotting time-series data using zoom-cache files.+ .+ For more information on scope and zoom-cache, see their packages:+ .+ <http://hackage.haskell.org/package/scope>+ .+ <http://hackage.haskell.org/package/zoom-cache>+ .+ This package 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 gtk2hs-buildtools scope-cairo+ $ scope-cairo+ @+ .+ 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,+ MonadCatchIO-transformers > 0.2 && < 0.3,+ mtl >= 2.0.0.0 && < 3,+ old-locale,+ scope >= 0.8.0.0 && < 0.9,+ time,+ zoom-cache >= 1.2.0.0 && < 1.3.0.0++ Exposed-modules:+ Scope.Cairo++Executable scope-cairo+ 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,+ gtk,+ MonadCatchIO-transformers > 0.2 && < 0.3,+ mtl >= 2.0.0.0 && < 3,+ old-locale,+ scope >= 0.8.0.0 && < 0.9,+ time,+ zoom-cache >= 1.2.0.0 && < 1.3.0.0++------------------------------------------------------------------------+-- Git repo+--+source-repository head+ type: git+ location: git://github.com/kfish/scope-cairo.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,470 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS -Wall -fno-warn-unused-do-bind #-}++module GUI (+ guiMain+) where++import Control.Applicative ((<$>))+import Control.Concurrent+import Control.Monad.Reader+import Data.IORef+import Data.Maybe+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 qualified Graphics.Rendering.Cairo.Matrix as M+import System.Locale (defaultTimeLocale)++import Paths_scope_cairo as My+import Scope.Layer+import Scope.Types+import Scope.View++import Scope.Cairo++----------------------------------------------------------------------++windowWidth, windowHeight :: Int+windowWidth = 500+windowHeight = 500++-- 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)++ 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++ -- 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 = scopeCairoNew drawingArea adj+ scopeRef <- newIORef scope++ quita `G.on` G.actionActivated $ myQuit scopeRef window chan++ mapM_ (modifyIORefM scopeRef . addLayersFromFile) args+ openDialog `G.on` G.response $ myFileOpen scopeRef openDialog+ saveDialog `G.on` G.response $ myFileSave scopeRef saveDialog++ 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 => IORef (Scope ViewCairo) -> cls -> Chan String -> IO ()+myQuit scopeRef window chan = do+ scopeModifyMUpdate scopeRef scopeClose+ 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 ViewCairo) -> G.FileChooserDialog -> G.ResponseId -> IO ()+myFileOpen scopeRef fcdialog response = do+ case response of+ G.ResponseAccept -> do+ Just filename <- G.fileChooserGetFilename fcdialog+ scopeModifyMUpdate scopeRef (addLayersFromFile filename)+ _ -> return ()+ G.widgetHide fcdialog++myFileSave :: IORef (Scope ViewCairo) -> G.FileChooserDialog -> G.ResponseId -> IO ()+myFileSave scopeRef fcdialog response = do+ case response of+ G.ResponseAccept -> do+ Just filename <- G.fileChooserGetFilename fcdialog+ writePng filename scopeRef+ _ -> return ()+ G.widgetHide fcdialog++myCut :: IO ()+myCut = putStrLn "Cut"++myCopy :: IO ()+myCopy = putStrLn "Copy"++myPaste :: IO ()+myPaste = putStrLn "Paste"++myDelete :: IO ()+myDelete = putStrLn "Delete"++updateCanvas :: IORef (Scope ViewCairo) -> IO Bool+updateCanvas ref = do+ scope <- readIORef ref+ let c = canvas . viewUI . view $ scope+ win <- G.widgetGetDrawWindow c+ (width, height) <- G.widgetGetSize c+ G.renderWithDrawable win $ plotWindow width height ref+ return True++writePng :: FilePath -> IORef (Scope ViewCairo) -> IO ()+writePng path ref = do+ scope <- readIORef ref+ 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 ref+ C.surfaceWriteToPNG result path++----------------------------------------------------------------++scopeModifyMUpdate :: IORef (Scope ViewCairo)+ -> (Scope ViewCairo -> IO (Scope ViewCairo))+ -> IO ()+scopeModifyMUpdate ref f = do+ modifyIORefM ref f+ viewCairoUpdate =<< view <$> readIORef ref++scopeModifyUpdate :: IORef (Scope ViewCairo)+ -> (View ViewCairo -> View ViewCairo)+ -> IO ()+scopeModifyUpdate ref f = do+ 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+_canvasToScreen c (CanvasX cX) = do+ (width, _height) <- G.widgetGetSize c+ return $ ScreenX (fromIntegral width * cX)++screenToCanvas :: ViewCairo -> ScreenX -> IO CanvasX+screenToCanvas vc (ScreenX sX) = do+ (width, _height) <- G.widgetGetSize (canvas vc)+ return $ CanvasX (sX / fromIntegral width)++----------------------------------------------------------------++buttonDown :: IORef (Scope ViewCairo) -> G.EventM G.EButton ()+buttonDown ref = do+ (x, _y) <- G.eventCoordinates+ liftIO $ do+ vc <- viewUI . view <$> readIORef ref+ cX <- screenToCanvas vc (ScreenX x)+ scopeModifyUpdate ref (viewButtonDown cX)++buttonRelease :: IORef (Scope ViewCairo) -> G.EventM G.EButton ()+buttonRelease ref = liftIO $ modifyIORef ref (scopeModifyView viewButtonRelease)++motion :: IORef (Scope ViewCairo) -> G.EventM G.EMotion ()+motion ref = do+ (x, _y) <- G.eventCoordinates+ liftIO $ do+ View{..} <- view <$> readIORef ref+ cX <- screenToCanvas viewUI (ScreenX x)+ scopeModifyUpdate ref (viewButtonMotion cX)++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 viewUI (ScreenX x)+ case dir of+ G.ScrollUp -> scopeModifyUpdate ref (viewZoomInOn cX 1.2)+ G.ScrollDown -> scopeModifyUpdate ref (viewZoomOutOn cX 1.2)+ _ -> return ()++scroll :: IORef (Scope ViewCairo) -> IO ()+scroll ref = do+ val <- G.adjustmentGetValue =<< adj . viewUI . view <$> readIORef ref+ scopeModifyUpdate ref (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 ViewCairo) -> G.EventM G.EKey ()+keyDown ref = do+ v <- G.eventKeyVal+ -- n <- G.eventKeyName+ -- liftIO . putStrLn $ printf "Key %s (%d) pressed" n v+ 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++ maybe (return ()) (liftIO . scopeModifyUpdate ref) f++----------------------------------------------------------------++plotWindow :: Int -> Int -> IORef (Scope ViewCairo) -> C.Render ()+plotWindow width height ref = do+ scope <- liftIO $ readIORef ref+ prologue width height+ modifyIORefM ref plotLayers+ plotTimeline scope+ plotCursor scope++-- Set up stuff+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+ 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++----------------------------------------------------------------------++plotCursor :: Scope ViewCairo -> C.Render ()+plotCursor scope = maybe (return ()) f pointerX+ where+ View{..} = view scope+ f :: CanvasX -> C.Render ()+ f (CanvasX cX) = do+ C.setSourceRGBA 0 0.7 0 0.4+ C.moveTo cX (-1.0)+ C.lineTo cX 1.0+ C.stroke++----------------------------------------------------------------------++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 (dataToUTC scope viewX1, dataToUTC scope viewX2) of+ (Just s, Just e) -> do+ plotAllTicks s e+ plotAllLabels s e+ _ -> 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 :: Timelineable a => a -> a -> C.Render ()+ plotAllTicks s e = do+ plotTicks 0.001 0.05 s e+ plotTicks 0.01 0.1 s e+ plotTicks 0.02 1.0 s e+ plotTicks 0.04 5.0 s e+ plotTicks 0.06 10.0 s e+ plotTicks 0.08 60.0 s e+ plotTicks 0.10 3600.0 s e++ 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+ start' = toDouble start+ end' = toDouble end++ 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 :: 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)+ steps = take 1 . filter readable $ [3600, 60, 10, 5, 1, 0.1, 0.05]+ start' = toDouble start+ end' = toDouble end++ 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 start . fromDouble) [s, s+step .. end']+ where+ start' = toDouble start+ end' = toDouble end++ 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+ C.selectFontFace "sans" C.FontSlantNormal C.FontWeightNormal+ C.setFontSize 0.02+ C.moveTo x y+ C.textPath s+ C.fillPreserve++plotArrow :: CanvasX -> C.Render ()+plotArrow (CanvasX cX) = do+ C.setSourceRGBA 0 0 0 0.9+ C.moveTo (cX-0.004) (0.99)+ C.lineTo (cX+0.004) (0.99)+ C.lineTo cX (0.98)+ C.fill++----------------------------------------------------------------------++modifyIORefM :: MonadIO m => IORef a -> (a -> m a) -> m ()+modifyIORefM ref f = do+ x <- liftIO $ readIORef ref+ x' <- f x+ liftIO $ 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