Events.hs

module PlotLab.Events (attachHandlers) where

import           PlotLab.FigureSettings

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

attachHandlers :: (Ordinate a, ComboBoxClass self) =>
                  Builder
                  -> IORef FigureSettings
                  -> [Adjustment]
                  -> (DrawingArea ->
                      IORef FigureSettings -> [Adjustment] -> IO ())
                  -> ([Double] -> a)
                  -> ((Vector Double, [FormattedSeries])
                      -> FigureSettings -> Figure ())
                  -> self
                  -> IO (ConnectId Button)
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_ (`onValueChanged` 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
    modifyIORef iofset
      (\f -> f { showXAxis = state })
    redraw

  -- Show Y-Axis CheckButton
  showY <- builderGetObject builder castToCheckButton "Y-Axis Check"
  _ <- onToggled showY $ do
    state <- toggleButtonGetActive showY
    modifyIORef iofset
      (\f -> f { showYAxis = state })
    redraw

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

  -- X-Range Auto-determination CheckBox
  xRangeEntries <- 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 xRangeEntries
      else do lower <- builderGetObject builder castToAdjustment "X-Lower"
              upper <- builderGetObject builder castToAdjustment "X-Upper"
              (l, u) <- adjustmentPairValues (lower, upper)
              widgetShowAll xRangeEntries
              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, yu) <- adjustmentPairValues (yLower, yUpper)
        modifyIORef iofset $ \f -> f { yRange = Just (yl, yu) }
        redraw
    in mapM_ updateY [yLower, yUpper]

  -- Y-Range Auto-determination CheckBox
  yRangeEntries <- 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 yRangeEntries
      else do lower <- builderGetObject builder castToAdjustment "Y-Lower"
              upper <- builderGetObject builder castToAdjustment "Y-Upper"
              (l, u) <- adjustmentPairValues (lower, upper)
              widgetShowAll yRangeEntries
              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
    label' <- entryGetText xLabelEntry
    modifyIORef iofset $ \f -> f { xLabel = Just label' }
    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
    label' <- entryGetText yLabelEntry
    modifyIORef iofset $ \f -> f { yLabel = Just label' }
    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
        colour = blue :: Color
        dset = (domain, [line f colour])
        dimensions = exportSize fset

        parseType txt = case txt of
                         "PNG" -> PNG
                         "SVG" -> SVG
                         "PS"  -> PS
                         "PDF" -> PDF
                         _     -> error "Invalid FileType!"


        filetype = let ftype = maybe (error "Invalid FileType!") unpack 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