{-# 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'