Dial.hs

{-|
Module      : Monomer.Widgets.Singles.Dial
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Dial widget, used for interacting with numeric values. It allows changing the
value using the keyboard arrows, dragging the mouse or using the wheel.

@
dial numericLens 0 100
@

Similar in objective to "Monomer.Widgets.Singles.Slider", but uses less visual
space in its parent container.
-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}

module Monomer.Widgets.Singles.Dial (
  -- * Configuration
  DialValue,
  DialCfg,
  -- * Constructors
  dial,
  dial_,
  dialV,
  dialV_,
  dialD_
) where

import Control.Applicative ((<|>))
import Control.Lens (ALens', (&), (^.), (.~), (<>~))
import Data.Default
import Data.Maybe
import Data.Typeable (Typeable, typeOf)
import GHC.Generics
import TextShow

import qualified Data.Sequence as Seq

import Monomer.Helper
import Monomer.Widgets.Single

import qualified Monomer.Lens as L

-- | Constraints for numeric types accepted by dial.
type DialValue a = (Eq a, Show a, Real a, FromFractional a, Typeable a)

{-|
Configuration options for dial:

- 'width': sets the max width/height of the dial.
- 'wheelRate': The rate at which wheel movement affects the number.
- 'dragRate': The rate at which drag movement affects the number.
- 'onFocus': event to raise when focus is received.
- 'onFocusReq': 'WidgetRequest' to generate when focus is received.
- 'onBlur': event to raise when focus is lost.
- 'onBlurReq': 'WidgetRequest' to generate when focus is lost.
- 'onChange': event to raise when the value changes.
- 'onChangeReq': 'WidgetRequest' to generate when the value changes.
-}
data DialCfg s e a = DialCfg {
  _dlcWidth :: Maybe Double,
  _dlcWheelRate :: Maybe Rational,
  _dlcDragRate :: Maybe Rational,
  _dlcOnFocusReq :: [Path -> WidgetRequest s e],
  _dlcOnBlurReq :: [Path -> WidgetRequest s e],
  _dlcOnChangeReq :: [a -> WidgetRequest s e]
}

instance Default (DialCfg s e a) where
  def = DialCfg {
    _dlcWidth = Nothing,
    _dlcWheelRate = Nothing,
    _dlcDragRate = Nothing,
    _dlcOnFocusReq = [],
    _dlcOnBlurReq = [],
    _dlcOnChangeReq = []
  }

instance Semigroup (DialCfg s e a) where
  (<>) t1 t2 = DialCfg {
    _dlcWidth = _dlcWidth t2 <|> _dlcWidth t1,
    _dlcWheelRate = _dlcWheelRate t2 <|> _dlcWheelRate t1,
    _dlcDragRate = _dlcDragRate t2 <|> _dlcDragRate t1,
    _dlcOnFocusReq = _dlcOnFocusReq t1 <> _dlcOnFocusReq t2,
    _dlcOnBlurReq = _dlcOnBlurReq t1 <> _dlcOnBlurReq t2,
    _dlcOnChangeReq = _dlcOnChangeReq t1 <> _dlcOnChangeReq t2
  }

instance Monoid (DialCfg s e a) where
  mempty = def

instance CmbWheelRate (DialCfg s e a) Rational where
  wheelRate rate = def {
    _dlcWheelRate = Just rate
  }

instance CmbDragRate (DialCfg s e a) Rational where
  dragRate rate = def {
    _dlcDragRate = Just rate
  }

instance CmbWidth (DialCfg s e a) where
  width w = def {
    _dlcWidth = Just w
  }

instance WidgetEvent e => CmbOnFocus (DialCfg s e a) e Path where
  onFocus fn = def {
    _dlcOnFocusReq = [RaiseEvent . fn]
  }

instance CmbOnFocusReq (DialCfg s e a) s e Path where
  onFocusReq req = def {
    _dlcOnFocusReq = [req]
  }

instance WidgetEvent e => CmbOnBlur (DialCfg s e a) e Path where
  onBlur fn = def {
    _dlcOnBlurReq = [RaiseEvent . fn]
  }

instance CmbOnBlurReq (DialCfg s e a) s e Path where
  onBlurReq req = def {
    _dlcOnBlurReq = [req]
  }

instance WidgetEvent e => CmbOnChange (DialCfg s e a) a e where
  onChange fn = def {
    _dlcOnChangeReq = [RaiseEvent . fn]
  }

instance CmbOnChangeReq (DialCfg s e a) s e a where
  onChangeReq req = def {
    _dlcOnChangeReq = [req]
  }

data DialState = DialState {
  _dlsMaxPos :: Integer,
  _dlsPos :: Integer
} deriving (Eq, Show, Generic)

-- | Creates a dial using the given lens, providing minimum and maximum values.
dial
  :: (DialValue a, WidgetEvent e)
  => ALens' s a      -- ^ The lens into the model.
  -> a               -- ^ Minimum value.
  -> a               -- ^ Maximum value.
  -> WidgetNode s e  -- ^ The created dial.
dial field minVal maxVal = dial_ field minVal maxVal def

{-|
Creates a dial using the given lens, providing minimum and maximum values.
Accepts config.
-}
dial_
  :: (DialValue a, WidgetEvent e)
  => ALens' s a       -- ^ The lens into the model.
  -> a                -- ^ Minimum value.
  -> a                -- ^ Maximum value.
  -> [DialCfg s e a]  -- ^ The config options.
  -> WidgetNode s e   -- ^ The created dial.
dial_ field minVal maxVal cfgs = dialD_ (WidgetLens field) minVal maxVal cfgs

{-|
Creates a dial using the given value and 'onChange' event handler, providing
minimum and maximum values.
-}
dialV
  :: (DialValue a, WidgetEvent e)
  => a               -- ^ The current value.
  -> (a -> e)        -- ^ The event to raise on change.
  -> a               -- ^ Minimum value.
  -> a               -- ^ Maximum value.
  -> WidgetNode s e  -- ^ The created dial.
dialV value handler minVal maxVal = dialV_ value handler minVal maxVal def

{-|
Creates a dial using the given value and 'onChange' event handler, providing
minimum and maximum values.
Accepts config.
-}
dialV_
  :: (DialValue a, WidgetEvent e)
  => a                -- ^ The current value.
  -> (a -> e)         -- ^ The event to raise on change.
  -> a                -- ^ Minimum value.
  -> a                -- ^ Maximum value.
  -> [DialCfg s e a]  -- ^ The config options.
  -> WidgetNode s e   -- ^ The created dial.
dialV_ value handler minVal maxVal configs = newNode where
  widgetData = WidgetValue value
  newConfigs = onChange handler : configs
  newNode = dialD_ widgetData minVal maxVal newConfigs

{-|
Creates a dial providing a 'WidgetData' instance, minimum and maximum values and
config.
-}
dialD_
  :: (DialValue a, WidgetEvent e)
  => WidgetData s a   -- ^ The 'WidgetData' to retrieve the value from.
  -> a                -- ^ Minimum value.
  -> a                -- ^ Maximum value.
  -> [DialCfg s e a]  -- ^ The config options.
  -> WidgetNode s e   -- ^ The created dial.
dialD_ widgetData minVal maxVal configs = dialNode where
  config = mconcat configs
  state = DialState 0 0
  wtype = WidgetType ("dial-" <> showt (typeOf minVal))
  widget = makeDial widgetData minVal maxVal config state
  dialNode = defaultWidgetNode wtype widget
    & L.info . L.focusable .~ True

makeDial
  :: (DialValue a, WidgetEvent e)
  => WidgetData s a
  -> a
  -> a
  -> DialCfg s e a
  -> DialState
  -> Widget s e
makeDial !field !minVal !maxVal !config !state = widget where
  widget = createSingle state def {
    singleFocusOnBtnPressed = False,
    singleGetBaseStyle = getBaseStyle,
    singleGetCurrentStyle = getCurrentStyle,
    singleInit = init,
    singleMerge = merge,
    singleFindByPoint = findByPoint,
    singleHandleEvent = handleEvent,
    singleGetSizeReq = getSizeReq,
    singleRender = render
  }

  dragRate
    | isJust (_dlcDragRate config) = fromJust (_dlcDragRate config)
    | otherwise = toRational (maxVal - minVal) / 1000

  getBaseStyle wenv node = Just style where
    style = collectTheme wenv L.dialStyle

  getCurrentStyle wenv node = style where
    (_, dialArea) = getDialInfo wenv node config
    style = currentStyle_ (currentStyleConfig dialArea) wenv node

  init wenv node = resultNode resNode where
    newState = newStateFromModel wenv node state
    resNode = node
      & L.widget .~ makeDial field minVal maxVal config newState

  merge wenv newNode oldNode oldState = resultNode resNode where
    newState
      | isNodePressed wenv newNode = oldState
      | otherwise = newStateFromModel wenv newNode oldState
    resNode = newNode
      & L.widget .~ makeDial field minVal maxVal config newState

  findByPoint wenv node path point
    | isVisible && pointInEllipse point dialArea = Just wni
    | otherwise = Nothing
    where
      isVisible = node ^. L.info . L.visible
      wni = node ^. L.info
      (_, dialArea) = getDialInfo wenv node config

  handleEvent wenv node target evt = case evt of
    Focus prev -> handleFocusChange node prev (_dlcOnFocusReq config)

    Blur next -> handleFocusChange node next (_dlcOnBlurReq config)

    KeyAction mod code KeyPressed
      | ctrlPressed && isKeyUp code -> handleNewPos (pos + warpSpeed)
      | ctrlPressed && isKeyDown code -> handleNewPos (pos - warpSpeed)
      | shiftPressed && isKeyUp code -> handleNewPos (pos + baseSpeed)
      | shiftPressed && isKeyDown code -> handleNewPos (pos - baseSpeed)
      | isKeyUp code -> handleNewPos (pos + fastSpeed)
      | isKeyDown code -> handleNewPos (pos - fastSpeed)
      where
        DialState maxPos pos = state
        ctrlPressed = isShortCutControl wenv mod
        baseSpeed = max 1 $ round (fromIntegral maxPos / 1000)
        fastSpeed = max 1 $ round (fromIntegral maxPos / 100)
        warpSpeed = max 1 $ round (fromIntegral maxPos / 10)
        vPos pos = clamp 0 maxPos pos
        newResult !newPos = addReqsEvts (resultNode newNode) newVal where
          newVal = valueFromPos minVal dragRate newPos
          !newState = state { _dlsPos = newPos }
          !newNode = node
            & L.widget .~ makeDial field minVal maxVal config newState
        handleNewPos !newPos
          | vPos newPos /= pos = Just $ newResult (vPos newPos)
          | otherwise = Nothing

    Move point
      | isNodePressed wenv node -> Just result where
        (_, start) = fromJust $ wenv ^. L.mainBtnPress
        (_, newVal) = posFromPoint minVal maxVal state dragRate start point
        result = addReqsEvts (resultReqs node [RenderOnce]) newVal

    ButtonAction point btn BtnPressed clicks
      | not (isNodeFocused wenv node) && not shiftPressed -> Just result where
        result = resultReqs node [SetFocus widgetId]

    ButtonAction point btn BtnReleased clicks -> Just result where
      reqs = [RenderOnce]
      newState = newStateFromModel wenv node state
      newNode = node
        & L.widget .~ makeDial field minVal maxVal config newState
      result = resultReqs newNode reqs

    WheelScroll _ (Point _ wy) wheelDirection -> Just result where
      DialState maxPos pos = state
      wheelCfg = fromMaybe (theme ^. L.sliderWheelRate) (_dlcWheelRate config)
      wheelRate = fromRational wheelCfg
      tmpPos = pos + round (wy * wheelRate)
      newPos = clamp 0 maxPos tmpPos
      newVal = valueFromPos minVal dragRate newPos
      reqs = [RenderOnce, IgnoreParentEvents]
      result = addReqsEvts (resultReqs node reqs) newVal
    _ -> Nothing
    where
      theme = currentTheme wenv node
      (_, dialArea) = getDialInfo wenv node config
      widgetId = node ^. L.info . L.widgetId
      path = node ^. L.info . L.path

      shiftPressed = wenv ^. L.inputStatus . L.keyMod . L.leftShift
      isSelectKey code = isKeyReturn code || isKeySpace code
      addReqsEvts result newVal = newResult where
        currVal = widgetDataGet (wenv ^. L.model) field
        reqs = widgetDataSet field newVal
          ++ fmap ($ newVal) (_dlcOnChangeReq config)
        newResult
          | currVal /= newVal = result
              & L.requests <>~ Seq.fromList reqs
          | otherwise = result

  getSizeReq wenv node = req where
    theme = currentTheme wenv node
    width = fromMaybe (theme ^. L.dialWidth) (_dlcWidth config)
    req = (fixedSize width, fixedSize width)

  render wenv node renderer = do
    drawArcBorder renderer dialArea start endSnd CW (Just sndColor) dialBW
    drawArcBorder renderer dialArea start endFg CW (Just fgColor) dialBW
    where
      (dialCenter, dialArea) = getDialInfo wenv node config
      DialState maxPos pos = newStateFromModel wenv node state
      posPct = fromIntegral pos / fromIntegral maxPos
      dialBW = max 1 (_rW dialArea * 0.15)
      style = getCurrentStyle wenv node
      fgColor = styleFgColor style
      sndColor = styleSndColor style
      start = 90 + 45
      endFg = start + 270 * posPct
      endSnd = 45

  newStateFromModel wenv node oldState = newState where
    currVal = widgetDataGet (wenv ^. L.model) field
    newMaxPos = round (toRational (maxVal - minVal) / dragRate)
    newPos = round (toRational (currVal - minVal) / dragRate)
    newState = oldState {
      _dlsMaxPos = newMaxPos,
      _dlsPos = newPos
    }

posFromPoint
  :: DialValue a
  => a
  -> a
  -> DialState
  -> Rational
  -> Point
  -> Point
  -> (Integer, a)
posFromPoint minVal maxVal state dragRate stPoint point = (newPos, newVal) where
  DialState maxPos pos = state
  Point _ dy = subPoint stPoint point
  tmpPos = pos + round dy
  newPos = clamp 0 maxPos tmpPos
  newVal = valueFromPos minVal dragRate newPos

valueFromPos :: DialValue a => a -> Rational -> Integer -> a
valueFromPos !minVal !dragRate !newPos = newVal where
  newVal = minVal + fromFractional (dragRate * fromIntegral newPos)

getDialInfo :: WidgetEnv s e -> WidgetNode s e -> DialCfg s e a -> (Point, Rect)
getDialInfo wenv node config = (dialCenter, dialArea) where
  theme = currentTheme wenv node
  style = currentStyle wenv node
  carea = getContentArea node style

  dialW = fromMaybe (theme ^. L.dialWidth) (_dlcWidth config)
  dialL = _rX carea + (_rW carea - dialW) / 2
  dialT = _rY carea + (_rH carea - dialW) / 2
  !dialCenter = Point (dialL + dialW / 2) (dialT + dialW / 2)
  !dialArea = Rect dialL dialT dialW dialW

currentStyleConfig :: Rect -> CurrentStyleCfg s e
currentStyleConfig dialArea = def
  & L.isHovered .~ isNodeHoveredEllipse_ dialArea