plot-gtk-ui-0.0.1.0: lib/Graphics/Rendering/Plot/Gtk/UI/PlotWindow.hs
-----------------------------------------------------------------------------
-- |
-- Module : Graphics.Rendering.Plot.Gtk.UI
-- Copyright : (c) Sumit Sahrawat
-- License : GPL-2
--
-- Maintainer : sumit.sahrawat.apm13@iitbhu.ac.in
-- Stability : provisional
-- Portability : portable
--
-- Functions related to the plot window
--
--------------------------------------------------------------------------------
module Graphics.Rendering.Plot.Gtk.UI.PlotWindow where
--------------------------------------------------------------------------------
-- Standard Libraries
import Control.Exception (SomeException (..),
catch)
import Control.Monad (when)
import Data.IORef (IORef, readIORef)
import Data.Maybe (fromJust, isJust,
isNothing)
import Data.Text (pack)
--------------------------------------------------------------------------------
-- Other Libraries
import Graphics.Rendering.Plot
import Graphics.UI.Gtk
--------------------------------------------------------------------------------
-- Custom Modules
import Graphics.Rendering.Plot.Gtk.UI.ErrorFig (errorFig)
import Graphics.Rendering.Plot.Gtk.UI.Events (attachHandlers)
import Graphics.Rendering.Plot.Gtk.UI.Figure (figurePlot)
import Graphics.Rendering.Plot.Gtk.UI.Settings
--------------------------------------------------------------------------------
updateCanvas :: ([Double] -> Double -> Double)
-> DrawingArea
-> IORef FigureSettings
-> [Adjustment]
-> IO ()
updateCanvas g canvas iofset adjs = do
s@(w, h) <- widgetGetSize canvas
drw <- widgetGetDrawWindow canvas
fig <- figurePlot g iofset adjs
box <- regionRectangle $ Rectangle 0 0 w h
drawWindowBeginPaintRegion drw box
catch (renderWithDrawable drw (render fig s))
(\(SomeException _) -> do
fset <- readIORef iofset
renderWithDrawable drw (errorFig fset s))
drawWindowEndPaint drw
--------------------------------------------------------------------------------
addSlidersToBox :: [AdjustmentSettings] -> VBox -> IO [Adjustment]
addSlidersToBox conf box = do
let newAdj (ASet a b c d e f) = adjustmentNew a b c d e f
newAdjList = mapM newAdj
newHScaleList = mapM hScaleNew
adjs <- newAdjList conf
sliders <- newHScaleList adjs
mapM_ (`scaleSetValuePos` PosRight) sliders
mapM_ (`scaleSetDigits` 2) sliders
mapM_ (\x -> boxPackEnd box x PackNatural 0) sliders
return adjs
--------------------------------------------------------------------------------
plotWindow :: String -> IORef FigureSettings -> [AdjustmentSettings]
-> ([Double] -> Double -> Double) -> IO ()
plotWindow plotGlade iofset conf fun = do
builder <- builderNew
builderAddFromFile builder plotGlade
plotBox <- builderGetObject builder castToVBox "Plot Region"
adjs <- addSlidersToBox conf plotBox
fset <- readIORef iofset
let updateEntryText entryGlade txt =
when (isJust txt) $ do entry <- builderGetObject builder
castToEntry entryGlade
entrySetText entry $ fromJust txt
in do updateEntryText "Plot Title Entry" $ plotTitle fset
updateEntryText "Subtitle Entry" $ subTitle fset
updateEntryText "X-Label Entry" $ xLabel fset
updateEntryText "Y-Label Entry" $ yLabel fset
updateEntryText "File Entry" $ Just (fileName fset)
let adjApplyValue adjGlade val = do
adj <- builderGetObject builder castToAdjustment adjGlade
adjustmentSetValue adj val
in do adjApplyValue "Title Font Size" $ plotTitleSize fset
adjApplyValue "Subtitle Font Size" $ subTitleSize fset
adjApplyValue "Sampling Adj" $ samplingRate fset
adjApplyValue "X-Label Size" $ xLabelSize fset
adjApplyValue "Y-Label Size" $ yLabelSize fset
let checkApplyState checkGlade state = do
check <- builderGetObject builder castToCheckButton checkGlade
toggleButtonSetActive check state
in do checkApplyState "X-Axis Check" $ showXAxis fset
checkApplyState "Y-Axis Check" $ showYAxis fset
checkApplyState "Y-Range Check" $ isNothing . yRange $ fset
when (isJust . yRange $ fset) $ do
let (l, u) = fromJust . yRange $ fset
lower <- builderGetObject builder castToAdjustment "Y-Lower"
upper <- builderGetObject builder castToAdjustment "Y-Upper"
adjustmentSetValue lower l
adjustmentSetValue upper u
-- X-Axis Range
let range = xRange fset
in if isNothing range
then error "Invalid xRange"
else let (l, u) = fromJust range
in do lower <- builderGetObject builder castToAdjustment "X-Lower"
upper <- builderGetObject builder castToAdjustment "X-Upper"
adjustmentSetValue lower l
adjustmentSetValue upper u
-- Export Size
let (w, h) = exportSize fset
in do widthAdj <- builderGetObject builder castToAdjustment "Export Width"
heightAdj <- builderGetObject builder castToAdjustment "Export Height"
adjustmentSetValue widthAdj $ fromIntegral w
adjustmentSetValue heightAdj $ fromIntegral h
-- Export ComboBox
combo <- comboBoxNewText
_ <- mapM (\(x, y) -> comboBoxInsertText combo x $ pack y)
[(1, "PNG"), (2, "SVG"), (3, "PS"), (4, "PDF")]
comboBoxSetActive combo 0
comboArea <- builderGetObject builder castToHBox "File Name"
boxPackEndDefaults comboArea combo
-- Attach Event Handlers
_ <- attachHandlers builder iofset adjs (updateCanvas fun) fun combo
-- Show Widgets
window <- builderGetObject builder castToWindow "Plot Window"
widgetShowAll window
-- Hide the useless checkButton for now
check <- builderGetObject builder castToCheckButton "X-Range Check"
widgetHide check
-- Hide the entries if not required
let range = yRange fset
in when (isNothing range) $ do
entries <- builderGetObject builder castToHBox "Y-Range Entries"
widgetHideAll entries
_ <- onDestroy window mainQuit
return ()
--------------------------------------------------------------------------------