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/Cairo.hs b/Scope/Cairo.hs new file mode 100644 --- /dev/null +++ b/Scope/Cairo.hs @@ -0,0 +1,76 @@ +{-# OPTIONS -Wall -fno-warn-orphans #-} + +module Scope.Cairo ( + -- * Types + ViewCairo(..) + + -- * Scope ViewCairo + , scopeCairoNew + , viewCairoInit + + -- * Utils + , keepState +) where + +import Prelude hiding (catch) + +import Control.Monad.CatchIO +import Control.Monad.Reader +import qualified Graphics.Rendering.Cairo as C +import Graphics.Rendering.Cairo.Internal (Render(..)) +import Graphics.Rendering.Cairo.Types (Cairo) +import qualified Graphics.UI.Gtk as G + +import Scope.Types hiding (m, b) + +---------------------------------------------------------------------- + +data ViewCairo = ViewCairo + { canvas :: G.DrawingArea + , adj :: G.Adjustment + } + +scopeCairoNew :: G.DrawingArea -> G.Adjustment -> Scope ViewCairo +scopeCairoNew c a = scopeNew (viewCairoInit c a) + +viewCairoInit :: G.DrawingArea -> G.Adjustment -> ViewCairo +viewCairoInit c a = ViewCairo c a + +---------------------------------------------------------------------- + +instance MonadCatchIO C.Render where + m `catch` f = mapRender (\m' -> m' `catch` \e -> runRender $ f e) m + block = mapRender block + unblock = mapRender unblock + +mapRender :: (ReaderT Cairo IO m1 -> ReaderT Cairo IO m) -> Render m1 -> Render m +mapRender f = Render . f . runRender + +instance ScopeRender C.Render where + renderCmds = keepState . mapM_ cairoDrawCmd + +---------------------------------------------------------------------- + +cairoDrawCmd :: DrawCmd -> C.Render () +cairoDrawCmd (SetRGB r g b) = C.setSourceRGB r g b +cairoDrawCmd (SetRGBA r g b a) = C.setSourceRGBA r g b a +cairoDrawCmd (MoveTo (x,y)) = C.moveTo x y + +cairoDrawCmd (LineTo (x,y)) = do + C.lineTo x y + C.stroke + +cairoDrawCmd (FillPoly []) = return () +cairoDrawCmd (FillPoly ((x,y):ps)) = do + C.moveTo x y + mapM_ (uncurry C.lineTo) ps + C.fill + +---------------------------------------------------------------- + +keepState :: C.Render t -> C.Render () +keepState render = do + C.save + _ <- render + C.restore + diff --git a/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-cairo.cabal b/scope-cairo.cabal new file mode 100644 --- /dev/null +++ b/scope-cairo.cabal @@ -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: + . + + . + + . + 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 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,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' + 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