-- | Horizontal slider control.
module NanoUI.Widgets.Slider
  ( slider
  , slider'
  , sliderWith
  , sliderWith'
  )
where

import Control.Monad (when)
import Data.IORef (readIORef, writeIORef)
import Data.Text (Text)
import Effectful (Eff, type (:>))
import NanoUI.Context
  ( Context (..)
  , adoptStoreFloat
  , intKey
  , recordStoreFloat
  , registerFocusable
  , writeStoreFloat
  , getsOverlay
  , OverlayState (..)
  )
import NanoUI.Font (sliderHandleSlack, sliderTrackBounds)
import NanoUI.Frame.Hit (scrollHitRect)
import NanoUI.Id (WidgetId (..), hashWidgetId)
import NanoUI.Input (inputMouseDown, inputMousePressed)
import NanoUI.Layout.Arena (NodeType (..))
import NanoUI.Monad (Ui, askContext, askInput, nextId, uiIO, withKey)
import NanoUI.Style (Layout, defaultLayout, fillW)
import NanoUI.Types (Rect (..), clamp)
import NanoUI.Widgets.Behavior (DragAxis (..), KeyNav (..), useDrag1D, useKeyNav)
import NanoUI.Widgets.Node (Response, addWidget, setChanged)

-- | Slider over @[minV, maxV]@ that fills the available width. Pass the
-- current value; the result is the value after this frame's drag or arrow
-- keys.
{-# INLINE slider #-}
slider :: Ui :> es => Float -> Float -> Float -> Eff es Float
slider :: forall (es :: [Effect]).
(Ui :> es) =>
Float -> Float -> Float -> Eff es Float
slider Float
minV Float
maxV Float
value = (Response, Float) -> Float
forall a b. (a, b) -> b
snd ((Response, Float) -> Float)
-> Eff es (Response, Float) -> Eff es Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Layout -> Layout)
-> Float -> Float -> Float -> Eff es (Response, Float)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout)
-> Float -> Float -> Float -> Eff es (Response, Float)
sliderWith' Layout -> Layout
forall a. a -> a
id Float
minV Float
maxV Float
value

{-# INLINE slider' #-}
slider' :: Ui :> es => Float -> Float -> Float -> Eff es (Response, Float)
slider' :: forall (es :: [Effect]).
(Ui :> es) =>
Float -> Float -> Float -> Eff es (Response, Float)
slider' = (Layout -> Layout)
-> Float -> Float -> Float -> Eff es (Response, Float)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout)
-> Float -> Float -> Float -> Eff es (Response, Float)
sliderWith' Layout -> Layout
forall a. a -> a
id

-- | 'slider' with a layout modifier.
--
-- @
-- volume' <- sliderWith (fixedW 200) 0 100 volume
-- @
{-# INLINE sliderWith #-}
sliderWith :: Ui :> es => (Layout -> Layout) -> Float -> Float -> Float -> Eff es Float
sliderWith :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout) -> Float -> Float -> Float -> Eff es Float
sliderWith Layout -> Layout
f Float
minV Float
maxV Float
value = (Response, Float) -> Float
forall a b. (a, b) -> b
snd ((Response, Float) -> Float)
-> Eff es (Response, Float) -> Eff es Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Layout -> Layout)
-> Float -> Float -> Float -> Eff es (Response, Float)
forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout)
-> Float -> Float -> Float -> Eff es (Response, Float)
sliderWith' Layout -> Layout
f Float
minV Float
maxV Float
value

sliderWith' ::
  Ui :> es =>
  (Layout -> Layout) -> Float -> Float -> Float -> Eff es (Response, Float)
sliderWith' :: forall (es :: [Effect]).
(Ui :> es) =>
(Layout -> Layout)
-> Float -> Float -> Float -> Eff es (Response, Float)
sliderWith' Layout -> Layout
f Float
minV Float
maxV Float
value = do
  wid <- Eff es WidgetId
forall (es :: [Effect]). (Ui :> es) => Eff es WidgetId
nextId
  ctx <- askContext
  inp <- askInput
  uiIO $ registerFocusable ctx wid
  let key = WidgetId -> Int
intKey WidgetId
wid
  current <- uiIO $ adoptStoreFloat ctx wid key value
  let
    frac = if Float
maxV Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
minV then (Float
current Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
minV) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ (Float
maxV Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
minV) else Float
0
  resp <- addWidget wid NodeSlider "" frac (f (fillW defaultLayout))
  active <- uiIO (readIORef (ctxActiveId ctx))
  blocked <- uiIO (getsOverlay ctx osLastPointerBlocked)
  mrect <- uiIO (scrollHitRect ctx wid)
  let
    isActive = WidgetId
active WidgetId -> WidgetId -> Bool
forall a. Eq a => a -> a -> Bool
== WidgetId
wid
    heldByOther =
      Input -> Bool
inputMouseDown Input
inp
        Bool -> Bool -> Bool
&& Bool -> Bool
not (Input -> Bool
inputMousePressed Input
inp)
        Bool -> Bool -> Bool
&& WidgetId -> Word64
hashWidgetId WidgetId
active Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0
        Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isActive
    track0 =
      case Maybe Rect
mrect of
        Just (Rect Float
x Float
y Float
w Float
h) ->
          let tr :: Rect
tr = Float -> Float -> Float -> Float -> Rect
sliderTrackBounds Float
x Float
y Float
w Float
h
           in Float -> Float -> Float -> Float -> Rect
Rect (Rect -> Float
rectX Rect
tr) (Rect -> Float
rectY Rect
tr Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
sliderHandleSlack) (Rect -> Float
rectW Rect
tr) (Rect -> Float
rectH Rect
tr Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
sliderHandleSlack)
        Maybe Rect
Nothing -> Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0
    track = if Bool
blocked Bool -> Bool -> Bool
|| Bool
heldByOther then Float -> Float -> Float -> Float -> Rect
Rect Float
0 Float
0 Float
0 Float
0 else Rect
track0
  (dragged, dragging) <- withKey ("drag" :: Text) (useDrag1D DragAxisX minV maxV current track)
  when (dragging && not isActive) $ uiIO $ writeIORef (ctxActiveId ctx) wid
  when ((not dragging || blocked) && isActive) $
    uiIO $ writeIORef (ctxActiveId ctx) (WidgetId 0)
  nav <- useKeyNav wid
  let
    range = Float
maxV Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
minV
    step = if Float
range Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
0 then Float
range Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100 else Float
0
    navStep =
      (if KeyNav -> Bool
knRight KeyNav
nav Bool -> Bool -> Bool
|| KeyNav -> Bool
knUp KeyNav
nav then Int
1 else Int
0 :: Int)
        Int -> Int -> Int
forall a. Num a => a -> a -> a
- (if KeyNav -> Bool
knLeft KeyNav
nav Bool -> Bool -> Bool
|| KeyNav -> Bool
knDown KeyNav
nav then Int
1 else Int
0)
    baseVal = if Bool
dragging then Float
dragged else Float
current
    finalVal = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
minV Float
maxV (Float
baseVal Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
navStep Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
step)
  uiIO $ do
    writeStoreFloat ctx wid key finalVal
    recordStoreFloat ctx key finalVal
  pure (setChanged (finalVal /= current) resp, finalVal)