Events.hs

module PlotLab.Events (attachHandlers) where

import PlotLab.FigureSettings

import Data.Maybe (fromJust)
import Data.Colour.Names
import Graphics.Rendering.Plot
import Graphics.UI.Gtk hiding(Circle,Cross)
import Data.Text (pack, unpack)
import Numeric.LinearAlgebra (linspace)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef)
import Data.Char (toLower)

attachHandlers builder iofset adjs updateCanvas g buildFigure combo = do
  -- Canvas
  canvas <- builderGetObject builder castToDrawingArea "Plotting Canvas"
  let redraw = updateCanvas canvas iofset adjs
  onExpose canvas $ \_ -> redraw >> return False

  -- Adjustments for parameter sliders
  mapM_ (\x -> onValueChanged x redraw) adjs

  -- Plot-Title Entry
  titleEntry <- builderGetObject builder castToEntry "Plot Title Entry"
  onEntryActivate titleEntry $ do
    titleNew <- entryGetText titleEntry
    modifyIORef iofset $ \f -> f { plotTitle = Just titleNew }
    redraw

  -- Plot-Title Font Size
  titleSize <- builderGetObject builder castToAdjustment "Title Font Size"
  onValueChanged titleSize $ do
    size <- adjustmentGetValue titleSize
    modifyIORef iofset $ \f -> f { plotTitleSize = size }
    redraw

  -- Subtitle Entry
  subEntry <- builderGetObject builder castToEntry "Subtitle Entry"
  onEntryActivate subEntry $ do
    titleNew <- entryGetText subEntry
    modifyIORef iofset $ \f -> f { subTitle = Just titleNew }
    redraw

  -- Subtitle Font Size
  subSize  <- builderGetObject builder castToAdjustment "Subtitle Font Size"
  onValueChanged subSize $ do
    size <- adjustmentGetValue subSize
    modifyIORef iofset $ \f -> f { subTitleSize = size }
    redraw

  -- Show X-Axis CheckButton
  showX <- builderGetObject builder castToCheckButton "X-Axis Check"
  onToggled showX $ do
    state <- toggleButtonGetActive showX
    fset  <- readIORef iofset
    modifyIORef iofset
      (\f -> f { showXAxis = if state then True else False })
    redraw

  -- Show Y-Axis CheckButton
  showY <- builderGetObject builder castToCheckButton "Y-Axis Check"
  onToggled showY $ do
    state <- toggleButtonGetActive showY
    fset  <- readIORef iofset
    modifyIORef iofset
      (\f -> f { showYAxis = if state then True else False })
    redraw

  -- X-Axis Range
  xLower <- builderGetObject builder castToAdjustment "X-Lower"
  xUpper <- builderGetObject builder castToAdjustment "X-Upper"
  let updateX x = onValueChanged x $ do
        xl <- adjustmentGetValue xLower
        xu <- adjustmentGetValue xUpper
        modifyIORef iofset $ \f -> f { xRange = Just (xl, xu) }
        redraw
    in mapM_ updateX [xLower, xUpper]

  -- X-Range Auto-determination CheckBox
  rangeEntries <- builderGetObject builder castToHBox "X-Range Entries"
  autoXCheck <- builderGetObject builder castToCheckButton "X-Range Check"
  onToggled autoXCheck $ do
    state <- toggleButtonGetActive autoXCheck
    if state
      then error "Invalid xRange"
           -- do modifyIORef iofset $ \f -> f { xRange = Nothing }
           --    widgetHideAll rangeEntries
      else do lower <- builderGetObject builder castToAdjustment "X-Lower"
              upper <- builderGetObject builder castToAdjustment "X-Upper"
              l <- adjustmentGetValue lower
              u <- adjustmentGetValue upper
              widgetShowAll rangeEntries
              modifyIORef iofset $ \f -> f { xRange = Just (l, u) }
    redraw

  -- Y-Axis Range
  yLower <- builderGetObject builder castToAdjustment "Y-Lower"
  yUpper <- builderGetObject builder castToAdjustment "Y-Upper"
  let updateY y = onValueChanged y $ do
        yl <- adjustmentGetValue yLower
        yu <- adjustmentGetValue yUpper
        modifyIORef iofset $ \f -> f { yRange = Just (yl, yu) }
        redraw
    in mapM_ updateY [yLower, yUpper]

  -- Y-Range Auto-determination CheckBox
  rangeEntries <- builderGetObject builder castToHBox "Y-Range Entries"
  autoYCheck <- builderGetObject builder castToCheckButton "Y-Range Check"
  onToggled autoYCheck $ do
    state <- toggleButtonGetActive autoYCheck
    if state
      then do modifyIORef iofset $ \f -> f { yRange = Nothing }
              widgetHideAll rangeEntries
      else do lower <- builderGetObject builder castToAdjustment "Y-Lower"
              upper <- builderGetObject builder castToAdjustment "Y-Upper"
              l <- adjustmentGetValue lower
              u <- adjustmentGetValue upper
              widgetShowAll rangeEntries
              modifyIORef iofset $ \f -> f { yRange = Just (l, u) }
    redraw

  -- Sampling Rate
  sampleRate  <- builderGetObject builder castToAdjustment "Sampling Adj"
  onValueChanged sampleRate $ do
    rate <- adjustmentGetValue sampleRate
    modifyIORef iofset $ \f -> f { samplingRate = floor rate }
    redraw

  -- X-Label Entry
  xLabelEntry <- builderGetObject builder castToEntry "X-Label Entry"
  onEntryActivate xLabelEntry $ do
    labelNew <- entryGetText xLabelEntry
    modifyIORef iofset $ \f -> f { xLabel = Just labelNew }
    redraw

  -- X-Label Size
  xlSize <- builderGetObject builder castToAdjustment "X-Label Size"
  onValueChanged xlSize $ do
    size <- adjustmentGetValue xlSize
    modifyIORef iofset $ \f -> f { xLabelSize = size }
    redraw

  -- Y-Label Entry
  yLabelEntry <- builderGetObject builder castToEntry "Y-Label Entry"
  onEntryActivate yLabelEntry $ do
    labelNew <- entryGetText yLabelEntry
    modifyIORef iofset $ \f -> f { yLabel = Just labelNew }
    redraw

  ylSize <- builderGetObject builder castToAdjustment "Y-Label Size"
  onValueChanged ylSize $ do
    size <- adjustmentGetValue ylSize
    modifyIORef iofset $ \f -> f { yLabelSize = size }
    redraw

  -- Export Filename extry

  -- Export Button
  export <- builderGetObject builder castToButton "Export Button"
  onClicked export $ do
    fset <- readIORef iofset
    vars <- mapM adjustmentGetValue adjs

    comboText <- comboBoxGetActiveText combo
    nameEntry <- builderGetObject builder castToEntry "File Entry"
    nameText  <- entryGetText nameEntry

    modifyIORef iofset $ \f -> f { fileName = nameText }

    let rate    = samplingRate fset
        samples = (\(x, y) -> rate * floor (y - x)) (fromJust $ xRange fset)
        domain  = linspace samples (fromJust $ xRange fset)
        f = g vars
        dset = (domain, [line f blue])
        dimensions = exportSize fset

        parseType txt = case txt of
                         "PNG" -> PNG
                         "SVG" -> SVG
                         "PS"  -> PS
                         "PDF" -> PDF

        filetype = let ftype = if comboText == Nothing
                               then error "Invalid FileType!"
                               else unpack $ fromJust comboText
                   in parseType ftype

        parseExt fileType = case fileType of
                        PNG -> "PNG"
                        SVG -> "SVG"
                        PS  -> "PS"
                        PDF -> "PDF"

        filename = nameText ++ "." ++ (map toLower $ parseExt filetype)
    writeFigure filetype filename dimensions $ buildFigure dset fset