-- | Scroll offsets, links and configuration kept in the widget store, the
-- wheel and glide tuning kept in the context, and the commands that move a
-- scroller: to an offset, by a delta or page, or onto a widget.
module NanoUI.Context.Scroll
  ( getScrollOffset
  , setScrollOffset
  , getScrollOffset2D
  , setScrollOffset2D
  , setScrollConfig
  , linkScrollAxes
    -- * Tuning
  , ScrollTuning (..)
  , defaultScrollTuning
  , getScrollTuning
  , setScrollTuning
  , getScrollStep
  , setScrollStep
  , resolveScrollStep
    -- * Geometry
  , ScrollAxes (..)
  , ScrollMetrics (..)
  , getScrollMetrics
  , cacheScrollMetrics
  , beginScrollMetrics
  , getScrollOffsetIn
  , setScrollOffsetIn
    -- * Commands
  , ScrollBehavior (..)
  , ScrollAlign (..)
  , scrollTo
  , scrollBy
  , scrollPages
  , scrollToStart
  , scrollToEnd
  , scrollIntoView
  , scrollRectIntoView
    -- * Glide
  , applyScrollTarget
  , scrollTargetOffset
  , scrollGliding
  , clampScrollOffset
  , cancelScrollGlide
  , stepScrollGlides
  ) where

import Control.Monad (unless, when)
import Data.IORef (modifyIORef', readIORef, writeIORef)
import Data.IntMap.Strict qualified as IM
import Data.IntSet qualified as IS

import NanoUI.Context.Core (damageWidget, getPrevRect, getStore, setStore)
import NanoUI.Context.Types
  ( Context (..)
  , ScrollAxes (..)
  , ScrollGlide (..)
  , ScrollState (..)
  , ScrollTuning (..)
  , defaultScrollTuning
  , intKey
  )
import NanoUI.Draw qualified as Draw
import NanoUI.Frame.Scroll.Geometry
  ( ScrollConfig
  , decodeScrollConfig
  , defaultScrollConfig
  , encodeScrollConfig
  , scrollConfigNative2D
  )
import NanoUI.Id (WidgetId)
import NanoUI.Store
  ( WidgetStore (..)
  , slotKey
  , Slot (..)
  )
import NanoUI.Types (DamageBounds (..), Rect (..), V2 (..), clamp, onGrid, v2X, v2Y)

{-# INLINE snapScrollOffset #-}
snapScrollOffset :: Context -> Float -> IO Float
snapScrollOffset :: Context -> Float -> IO Float
snapScrollOffset Context
ctx Float
v = do
  s <- DrawArena -> IO Float
Draw.getDrawSnapScale (Context -> DrawArena
ctxDrawArena Context
ctx)
  pure (onGrid s v)

getScrollOffset :: Context -> WidgetId -> IO Float
getScrollOffset :: Context -> WidgetId -> IO Float
getScrollOffset Context
ctx WidgetId
wid = do
  s <- Context -> IO WidgetStore
getStore Context
ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      points = WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
s
      cfgBits = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (ScrollConfig -> Int
encodeScrollConfig ScrollConfig
defaultScrollConfig) (Slot -> Int -> Int
slotKey Slot
SlotScrollCfg Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
s)
      -- Text areas keep both axes in their own slot; native 2D scrollers keep
      -- them in the offset slot, falling back to the main-axis float as
      -- 'getScrollOffset2D' does.
      off = case Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Slot -> Int -> Int
slotKey Slot
SlotTextAreaScroll Int
key) IntMap (Float, Float)
points of
        Just (Float
_, Float
sy) -> Float
sy
        Maybe (Float, Float)
Nothing
          | ScrollConfig -> Bool
scrollConfigNative2D (Int -> ScrollConfig
decodeScrollConfig Int
cfgBits)
          , Just (Float
_, Float
y) <- Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Slot -> Int -> Int
slotKey Slot
SlotScrollOff Int
key) IntMap (Float, Float)
points ->
              Float
y
          | Bool
otherwise -> Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
key (WidgetStore -> IntMap Float
storeFloat WidgetStore
s)
  snapScrollOffset ctx off

-- | Move a scroller to an offset along its main axis. Cancels a glide in
-- flight: whoever sets an offset outright owns it.
setScrollOffset :: Context -> WidgetId -> Float -> IO ()
setScrollOffset :: Context -> WidgetId -> Float -> IO ()
setScrollOffset Context
ctx WidgetId
wid Float
off = do
  Context -> WidgetId -> IO ()
cancelScrollGlide Context
ctx WidgetId
wid
  Context -> WidgetId -> Float -> IO ()
writeScrollOffset Context
ctx WidgetId
wid Float
off

writeScrollOffset :: Context -> WidgetId -> Float -> IO ()
writeScrollOffset :: Context -> WidgetId -> Float -> IO ()
writeScrollOffset Context
ctx WidgetId
wid Float
off = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      sKey = Slot -> Int -> Int
slotKey Slot
SlotTextAreaScroll Int
key
  case IM.lookup sKey (storePoint store) of
    Just (Float
sx, Float
sy) ->
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
sy Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
off) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Context -> WidgetStore -> IO ()
setStore Context
ctx (WidgetStore
store {storePoint = IM.insert sKey (sx, off) (storePoint store)})
        Context -> WidgetId -> DamageBounds -> IO ()
damageWidget Context
ctx WidgetId
wid DamageBounds
DamageSelf
    Maybe (Float, Float)
Nothing -> do
      cfg <- Context -> WidgetId -> IO ScrollConfig
getScrollConfig Context
ctx WidgetId
wid
      if scrollConfigNative2D cfg
        then do
          cur <- getScrollOffset2D ctx wid
          writeScrollOffset2D ctx wid (V2 (v2X cur) off)
        else do
          let prev = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
key (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
          when (prev /= off) $ do
            let floats0 = Int -> Float -> IntMap Float -> IntMap Float
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
key Float
off (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
                yKey = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotScrollLinkY Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
            if yKey == 0
              then setStore ctx (store {storeFloat = floats0})
              else do
                let offKey = Slot -> Int -> Int
slotKey Slot
SlotScrollOff Int
yKey
                    crossKey = Slot -> Int -> Int
slotKey Slot
SlotScrollCross Int
yKey
                    prevY = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
yKey IntMap Float
floats0
                    floats1 = Int -> Float -> IntMap Float -> IntMap Float
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
yKey Float
prevY (IntMap Float -> IntMap Float) -> IntMap Float -> IntMap Float
forall a b. (a -> b) -> a -> b
$ Int -> Float -> IntMap Float -> IntMap Float
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
crossKey Float
off IntMap Float
floats0
                    points = Int
-> (Float, Float) -> IntMap (Float, Float) -> IntMap (Float, Float)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
offKey (Float
off, Float
prevY) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store)
                setStore ctx (store {storeFloat = floats1, storePoint = points})

getScrollOffset2D :: Context -> WidgetId -> IO V2
getScrollOffset2D :: Context -> WidgetId -> IO V2
getScrollOffset2D Context
ctx WidgetId
wid = do
  s <- Context -> IO WidgetStore
getStore Context
ctx
  let widKey = WidgetId -> Int
intKey WidgetId
wid
      sKey = Slot -> Int -> Int
slotKey Slot
SlotTextAreaScroll Int
widKey
  v <-
    case IM.lookup sKey (storePoint s) of
      Just (Float
sx, Float
sy) -> V2 -> IO V2
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> V2
V2 Float
sx Float
sy)
      Maybe (Float, Float)
Nothing -> do
        let offKey :: Int
offKey = Slot -> Int -> Int
slotKey Slot
SlotScrollOff Int
widKey
            crossKey :: Int
crossKey = Slot -> Int -> Int
slotKey Slot
SlotScrollCross Int
widKey
        case Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
offKey (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
s) of
          Just (Float
x, Float
y) -> V2 -> IO V2
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> Float -> V2
V2 Float
x Float
y)
          Maybe (Float, Float)
Nothing ->
            V2 -> IO V2
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              ( Float -> Float -> V2
V2
                  (Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
crossKey (WidgetStore -> IntMap Float
storeFloat WidgetStore
s))
                  (Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
widKey (WidgetStore -> IntMap Float
storeFloat WidgetStore
s))
              )
  sx <- snapScrollOffset ctx (v2X v)
  sy <- snapScrollOffset ctx (v2Y v)
  pure (V2 sx sy)

-- | Move a scroller to an offset on both axes. Cancels a glide in flight.
setScrollOffset2D :: Context -> WidgetId -> V2 -> IO ()
setScrollOffset2D :: Context -> WidgetId -> V2 -> IO ()
setScrollOffset2D Context
ctx WidgetId
wid V2
off = do
  Context -> WidgetId -> IO ()
cancelScrollGlide Context
ctx WidgetId
wid
  Context -> WidgetId -> V2 -> IO ()
writeScrollOffset2D Context
ctx WidgetId
wid V2
off

writeScrollOffset2D :: Context -> WidgetId -> V2 -> IO ()
writeScrollOffset2D :: Context -> WidgetId -> V2 -> IO ()
writeScrollOffset2D Context
ctx WidgetId
wid V2
off = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let widKey = WidgetId -> Int
intKey WidgetId
wid
      sKey = Slot -> Int -> Int
slotKey Slot
SlotTextAreaScroll Int
widKey
  -- Text areas only reach the first branch because `textAreaWith` seeds this
  -- slot at init; without the seed a freshly mounted editor falls through to
  -- the container slots below and its offsets are never rendered.
  case IM.lookup sKey (storePoint store) of
    Just (Float
sx, Float
sy) -> do
      let sx' :: Float
sx' = V2 -> Float
v2X V2
off
          sy' :: Float
sy' = V2 -> Float
v2Y V2
off
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Float
sx Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
sx' Bool -> Bool -> Bool
|| Float
sy Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
sy') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Context -> WidgetStore -> IO ()
setStore Context
ctx (WidgetStore
store {storePoint = IM.insert sKey (sx', sy') (storePoint store)})
        Context -> WidgetId -> DamageBounds -> IO ()
damageWidget Context
ctx WidgetId
wid DamageBounds
DamageSelf
    Maybe (Float, Float)
Nothing -> do
      let offKey :: Int
offKey = Slot -> Int -> Int
slotKey Slot
SlotScrollOff Int
widKey
          crossKey :: Int
crossKey = Slot -> Int -> Int
slotKey Slot
SlotScrollCross Int
widKey
          prev :: Maybe (Float, Float)
prev = Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
offKey (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store)
          next :: (Float, Float)
next = (V2 -> Float
v2X V2
off, V2 -> Float
v2Y V2
off)
          prevY :: Float
prevY = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
widKey (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
          prevX :: Float
prevX = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
crossKey (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
          xLink :: Int
xLink = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotScrollLinkX Int
widKey) (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Float, Float)
prev Maybe (Float, Float) -> Maybe (Float, Float) -> Bool
forall a. Eq a => a -> a -> Bool
/= (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float, Float)
next Bool -> Bool -> Bool
|| Float
prevY Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= V2 -> Float
v2Y V2
off Bool -> Bool -> Bool
|| Float
prevX Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= V2 -> Float
v2X V2
off) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let floats0 :: IntMap Float
floats0 =
              Int -> Float -> IntMap Float -> IntMap Float
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
widKey (V2 -> Float
v2Y V2
off) (IntMap Float -> IntMap Float) -> IntMap Float -> IntMap Float
forall a b. (a -> b) -> a -> b
$
                Int -> Float -> IntMap Float -> IntMap Float
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
crossKey (V2 -> Float
v2X V2
off) (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
            floats1 :: IntMap Float
floats1 =
              if Int
xLink Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then IntMap Float
floats0 else Int -> Float -> IntMap Float -> IntMap Float
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
xLink (V2 -> Float
v2X V2
off) IntMap Float
floats0
        Context -> WidgetStore -> IO ()
setStore Context
ctx
          ( WidgetStore
store
              { storePoint = IM.insert offKey next (storePoint store)
              , storeFloat = floats1
              }
          )

linkScrollAxes :: Context -> WidgetId -> WidgetId -> IO ()
linkScrollAxes :: Context -> WidgetId -> WidgetId -> IO ()
linkScrollAxes Context
ctx WidgetId
yWid WidgetId
xWid = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let yKey = WidgetId -> Int
intKey WidgetId
yWid
      xKey = WidgetId -> Int
intKey WidgetId
xWid
      ints =
        Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Slot -> Int -> Int
slotKey Slot
SlotScrollLinkX Int
yKey) Int
xKey (IntMap Int -> IntMap Int) -> IntMap Int -> IntMap Int
forall a b. (a -> b) -> a -> b
$
          Int -> Int -> IntMap Int -> IntMap Int
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert (Slot -> Int -> Int
slotKey Slot
SlotScrollLinkY Int
xKey) Int
yKey (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
  setStore ctx (store {storeInt = ints})
  V2 x2 y <- getScrollOffset2D ctx yWid
  x1 <- do
    s <- getStore ctx
    pure (IM.findWithDefault 0 xKey (storeFloat s))
  let x = if Float
x2 Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 Bool -> Bool -> Bool
&& Float
x1 Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
0 then Float
x1 else Float
x2
  when (x /= x2 || x /= x1) $
    setScrollOffset2D ctx yWid (V2 x y)

getScrollConfig :: Context -> WidgetId -> IO ScrollConfig
getScrollConfig :: Context -> WidgetId -> IO ScrollConfig
getScrollConfig Context
ctx WidgetId
wid = do
  s <- Context -> IO WidgetStore
getStore Context
ctx
  let cfgKey = Slot -> Int -> Int
slotKey Slot
SlotScrollCfg (WidgetId -> Int
intKey WidgetId
wid)
      bits = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (ScrollConfig -> Int
encodeScrollConfig ScrollConfig
defaultScrollConfig) Int
cfgKey (WidgetStore -> IntMap Int
storeInt WidgetStore
s)
  pure (decodeScrollConfig bits)

setScrollConfig :: Context -> WidgetId -> ScrollConfig -> IO ()
setScrollConfig :: Context -> WidgetId -> ScrollConfig -> IO ()
setScrollConfig Context
ctx WidgetId
wid ScrollConfig
cfg = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let cfgKey = Slot -> Int -> Int
slotKey Slot
SlotScrollCfg (WidgetId -> Int
intKey WidgetId
wid)
      bits = ScrollConfig -> Int
encodeScrollConfig ScrollConfig
cfg
      prev = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault (ScrollConfig -> Int
encodeScrollConfig ScrollConfig
defaultScrollConfig) Int
cfgKey (WidgetStore -> IntMap Int
storeInt WidgetStore
store)
  when (prev /= bits) $
    setStore ctx (store {storeInt = IM.insert cfgKey bits (storeInt store)})

-- =============================================================================
-- Tuning
-- =============================================================================

-- | Wheel step and glide time for every scroller in this context.
getScrollTuning :: Context -> IO ScrollTuning
getScrollTuning :: Context -> IO ScrollTuning
getScrollTuning Context
ctx = ScrollState -> ScrollTuning
ssTuning (ScrollState -> ScrollTuning) -> IO ScrollState -> IO ScrollTuning
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ScrollState -> IO ScrollState
forall a. IORef a -> IO a
readIORef (Context -> IORef ScrollState
ctxScrollState Context
ctx)

-- | Set the wheel step and glide time. Raising 'scrollWheelStep' makes the
-- wheel cover more ground per notch; a nonzero 'scrollSmoothTime' turns every
-- wheel notch and every 'ScrollSmooth' command into a glide.
setScrollTuning :: Context -> ScrollTuning -> IO ()
setScrollTuning :: Context -> ScrollTuning -> IO ()
setScrollTuning Context
ctx ScrollTuning
tuning =
  IORef ScrollState -> (ScrollState -> ScrollState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef ScrollState
ctxScrollState Context
ctx) ((ScrollState -> ScrollState) -> IO ())
-> (ScrollState -> ScrollState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScrollState
st -> ScrollState
st {ssTuning = tuning}

-- | This scroller's own wheel step, or @0@ when it follows the context's.
getScrollStep :: Context -> WidgetId -> IO Float
getScrollStep :: Context -> WidgetId -> IO Float
getScrollStep Context
ctx WidgetId
wid = do
  s <- Context -> IO WidgetStore
getStore Context
ctx
  pure (IM.findWithDefault 0 (slotKey SlotScrollStep (intKey wid)) (storeFloat s))

-- | Give one scroller its own wheel step, in pixels per notch. @0@ puts it
-- back on the context's step. A list whose rows are a fixed height reads best
-- at a whole number of rows per notch.
setScrollStep :: Context -> WidgetId -> Float -> IO ()
setScrollStep :: Context -> WidgetId -> Float -> IO ()
setScrollStep Context
ctx WidgetId
wid Float
px = do
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let key = Slot -> Int -> Int
slotKey Slot
SlotScrollStep (WidgetId -> Int
intKey WidgetId
wid)
      prev = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
key (WidgetStore -> IntMap Float
storeFloat WidgetStore
store)
  when (prev /= px) $
    setStore ctx (store {storeFloat = IM.insert key px (storeFloat store)})

-- | Pixels one wheel notch scrolls this scroller.
resolveScrollStep :: Context -> WidgetId -> IO Float
resolveScrollStep :: Context -> WidgetId -> IO Float
resolveScrollStep Context
ctx WidgetId
wid = do
  own <- Context -> WidgetId -> IO Float
getScrollStep Context
ctx WidgetId
wid
  if own > 0
    then pure own
    else max 1 . scrollWheelStep <$> getScrollTuning ctx

-- =============================================================================
-- Geometry
-- =============================================================================

-- | What a scroller looked like on the frame it was last laid out on.
-- Offsets and ranges are in window axes: @x@ rightwards, @y@ downwards,
-- whichever way the scroller itself is built.
data ScrollMetrics = ScrollMetrics
  { ScrollMetrics -> Rect
scrollViewport :: !Rect
  -- ^ The visible content, in window coordinates, inside padding and clear of
  -- the scrollbars.
  , ScrollMetrics -> V2
scrollRange :: !V2
  -- ^ Largest offset each axis reaches. @0@ on an axis that does not scroll.
  , ScrollMetrics -> V2
scrollOffset :: !V2
  -- ^ Where the scroller is now.
  , ScrollMetrics -> ScrollAxes
scrollAxes :: !ScrollAxes
  }
  deriving (ScrollMetrics -> ScrollMetrics -> Bool
(ScrollMetrics -> ScrollMetrics -> Bool)
-> (ScrollMetrics -> ScrollMetrics -> Bool) -> Eq ScrollMetrics
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScrollMetrics -> ScrollMetrics -> Bool
== :: ScrollMetrics -> ScrollMetrics -> Bool
$c/= :: ScrollMetrics -> ScrollMetrics -> Bool
/= :: ScrollMetrics -> ScrollMetrics -> Bool
Eq, Int -> ScrollMetrics -> ShowS
[ScrollMetrics] -> ShowS
ScrollMetrics -> String
(Int -> ScrollMetrics -> ShowS)
-> (ScrollMetrics -> String)
-> ([ScrollMetrics] -> ShowS)
-> Show ScrollMetrics
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScrollMetrics -> ShowS
showsPrec :: Int -> ScrollMetrics -> ShowS
$cshow :: ScrollMetrics -> String
show :: ScrollMetrics -> String
$cshowList :: [ScrollMetrics] -> ShowS
showList :: [ScrollMetrics] -> ShowS
Show)

-- | Geometry of the scroller @wid@, or 'Nothing' before it has been laid out.
-- Reads the last frame's layout, so it is safe to call while building the
-- next one.
getScrollMetrics :: Context -> WidgetId -> IO (Maybe ScrollMetrics)
getScrollMetrics :: Context -> WidgetId -> IO (Maybe ScrollMetrics)
getScrollMetrics Context
ctx WidgetId
wid = do
  s <- Context -> IO WidgetStore
getStore Context
ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      point Slot
slot = Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Slot -> Int -> Int
slotKey Slot
slot Int
key) (WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
s)
  case (point SlotScrollViewPos, point SlotScrollViewSize, point SlotScrollRange) of
    (Just (Float
vx, Float
vy), Just (Float
vw, Float
vh), Just (Float
mx, Float
my)) -> do
      let axes :: ScrollAxes
axes = Int -> ScrollAxes
decodeScrollAxes (Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Int
0 (Slot -> Int -> Int
slotKey Slot
SlotScrollAxes Int
key) (WidgetStore -> IntMap Int
storeInt WidgetStore
s))
      off <- Context -> WidgetId -> ScrollAxes -> IO V2
getScrollOffsetIn Context
ctx WidgetId
wid ScrollAxes
axes
      pure $
        Just
          ScrollMetrics
            { scrollViewport = Rect vx vy vw vh
            , scrollRange = V2 mx my
            , scrollOffset = off
            , scrollAxes = axes
            }
    (Maybe (Float, Float), Maybe (Float, Float), Maybe (Float, Float))
_ -> Maybe ScrollMetrics -> IO (Maybe ScrollMetrics)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ScrollMetrics
forall a. Maybe a
Nothing

-- | Start a frame's geometry pass: the first scroll node to publish under a
-- widget id wins for that frame.
beginScrollMetrics :: Context -> IO ()
beginScrollMetrics :: Context -> IO ()
beginScrollMetrics Context
ctx =
  IORef ScrollState -> (ScrollState -> ScrollState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef ScrollState
ctxScrollState Context
ctx) ((ScrollState -> ScrollState) -> IO ())
-> (ScrollState -> ScrollState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScrollState
st ->
    if IntSet -> Bool
IS.null (ScrollState -> IntSet
ssCached ScrollState
st) then ScrollState
st else ScrollState
st {ssCached = IS.empty}

-- | Record what the scroll pass measured, so the commands and the app can
-- read it between frames. Writes nothing when nothing moved, and nothing at
-- all for a second node sharing this one's widget id. A table's frozen pane
-- and its body share theirs, and letting both publish would rewrite the store
-- every frame and hand the commands a viewport that alternates between panes.
cacheScrollMetrics :: Context -> WidgetId -> ScrollAxes -> Rect -> V2 -> IO ()
cacheScrollMetrics :: Context -> WidgetId -> ScrollAxes -> Rect -> V2 -> IO ()
cacheScrollMetrics Context
ctx WidgetId
wid ScrollAxes
axes Rect
viewport V2
range = do
  taken <- Context -> Int -> IO Bool
claimScrollMetrics Context
ctx (WidgetId -> Int
intKey WidgetId
wid)
  unless taken (writeScrollMetrics ctx wid axes viewport range)

-- | Whether this widget id has already published geometry this frame; marks
-- it published if not.
claimScrollMetrics :: Context -> Int -> IO Bool
claimScrollMetrics :: Context -> Int -> IO Bool
claimScrollMetrics Context
ctx Int
key = do
  st <- IORef ScrollState -> IO ScrollState
forall a. IORef a -> IO a
readIORef (Context -> IORef ScrollState
ctxScrollState Context
ctx)
  if IS.member key (ssCached st)
    then pure True
    else do
      writeIORef (ctxScrollState ctx) $! st {ssCached = IS.insert key (ssCached st)}
      pure False

writeScrollMetrics :: Context -> WidgetId -> ScrollAxes -> Rect -> V2 -> IO ()
writeScrollMetrics :: Context -> WidgetId -> ScrollAxes -> Rect -> V2 -> IO ()
writeScrollMetrics Context
ctx WidgetId
wid ScrollAxes
axes (Rect Float
vx Float
vy Float
vw Float
vh) range :: V2
range@(V2 Float
mx Float
my) = do
  -- A range that just shrank (a filtered list, a narrower window) would leave
  -- a glide heading past the new end.
  Context -> WidgetId -> V2 -> IO ()
clampScrollGlide Context
ctx WidgetId
wid V2
range
  store <- Context -> IO WidgetStore
getStore Context
ctx
  let key = WidgetId -> Int
intKey WidgetId
wid
      axesKey = Slot -> Int -> Int
slotKey Slot
SlotScrollAxes Int
key
      posKey = Slot -> Int -> Int
slotKey Slot
SlotScrollViewPos Int
key
      sizeKey = Slot -> Int -> Int
slotKey Slot
SlotScrollViewSize Int
key
      rangeKey = Slot -> Int -> Int
slotKey Slot
SlotScrollRange Int
key
      code = ScrollAxes -> Int
encodeScrollAxes ScrollAxes
axes
      points = WidgetStore -> IntMap (Float, Float)
storePoint WidgetStore
store
      ints = WidgetStore -> IntMap Int
storeInt WidgetStore
store
      samePoint Int
k (Float, Float)
v = Int -> IntMap (Float, Float) -> Maybe (Float, Float)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
k IntMap (Float, Float)
points Maybe (Float, Float) -> Maybe (Float, Float) -> Bool
forall a. Eq a => a -> a -> Bool
== (Float, Float) -> Maybe (Float, Float)
forall a. a -> Maybe a
Just (Float, Float)
v
  unless
    ( samePoint posKey (vx, vy)
        && samePoint sizeKey (vw, vh)
        && samePoint rangeKey (mx, my)
        && IM.lookup axesKey ints == Just code
    )
    $ setStore ctx
      ( store
          { storePoint =
              IM.insert posKey (vx, vy) $
                IM.insert sizeKey (vw, vh) $
                  IM.insert rangeKey (mx, my) points
          , storeInt = IM.insert axesKey code ints
          }
      )

encodeScrollAxes :: ScrollAxes -> Int
encodeScrollAxes :: ScrollAxes -> Int
encodeScrollAxes = \case
  ScrollAxes
ScrollAxisY -> Int
0
  ScrollAxes
ScrollAxisX -> Int
1
  ScrollAxes
ScrollAxisXY -> Int
2

decodeScrollAxes :: Int -> ScrollAxes
decodeScrollAxes :: Int -> ScrollAxes
decodeScrollAxes = \case
  Int
1 -> ScrollAxes
ScrollAxisX
  Int
2 -> ScrollAxes
ScrollAxisXY
  Int
_ -> ScrollAxes
ScrollAxisY

-- | A 1D row scroller keeps its offset in the main-axis slot, so window and
-- stored axes are swapped for it and identical for everything else. The swap
-- is its own inverse.
{-# INLINE swapAxes #-}
swapAxes :: ScrollAxes -> V2 -> V2
swapAxes :: ScrollAxes -> V2 -> V2
swapAxes ScrollAxes
ScrollAxisX (V2 Float
x Float
y) = Float -> Float -> V2
V2 Float
y Float
x
swapAxes ScrollAxes
_ V2
v = V2
v

-- | This scroller's offset in window axes.
getScrollOffsetIn :: Context -> WidgetId -> ScrollAxes -> IO V2
getScrollOffsetIn :: Context -> WidgetId -> ScrollAxes -> IO V2
getScrollOffsetIn Context
ctx WidgetId
wid ScrollAxes
axes = ScrollAxes -> V2 -> V2
swapAxes ScrollAxes
axes (V2 -> V2) -> IO V2 -> IO V2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> WidgetId -> IO V2
getScrollOffset2D Context
ctx WidgetId
wid

-- | Move a scroller to an offset in window axes, cancelling any glide. A 1D
-- scroller ignores the axis it does not scroll on.
setScrollOffsetIn :: Context -> WidgetId -> ScrollAxes -> V2 -> IO ()
setScrollOffsetIn :: Context -> WidgetId -> ScrollAxes -> V2 -> IO ()
setScrollOffsetIn Context
ctx WidgetId
wid ScrollAxes
axes V2
off = do
  Context -> WidgetId -> IO ()
cancelScrollGlide Context
ctx WidgetId
wid
  Context -> WidgetId -> ScrollAxes -> V2 -> IO ()
writeScrollOffsetIn Context
ctx WidgetId
wid ScrollAxes
axes V2
off

writeScrollOffsetIn :: Context -> WidgetId -> ScrollAxes -> V2 -> IO ()
writeScrollOffsetIn :: Context -> WidgetId -> ScrollAxes -> V2 -> IO ()
writeScrollOffsetIn Context
ctx WidgetId
wid ScrollAxes
axes V2
off =
  case ScrollAxes
axes of
    ScrollAxes
ScrollAxisXY -> Context -> WidgetId -> V2 -> IO ()
writeScrollOffset2D Context
ctx WidgetId
wid V2
off
    ScrollAxes
ScrollAxisY -> Context -> WidgetId -> Float -> IO ()
writeScrollOffset Context
ctx WidgetId
wid (V2 -> Float
v2Y V2
off)
    ScrollAxes
ScrollAxisX -> Context -> WidgetId -> Float -> IO ()
writeScrollOffset Context
ctx WidgetId
wid (V2 -> Float
v2X V2
off)

-- =============================================================================
-- Commands
-- =============================================================================

-- | Whether a scroll lands on its target at once or glides onto it.
-- 'ScrollSmooth' still lands at once when the context's 'scrollSmoothTime' is
-- @0@, so one setting turns smooth scrolling on for the whole app.
data ScrollBehavior = ScrollInstant | ScrollSmooth
  deriving (ScrollBehavior -> ScrollBehavior -> Bool
(ScrollBehavior -> ScrollBehavior -> Bool)
-> (ScrollBehavior -> ScrollBehavior -> Bool) -> Eq ScrollBehavior
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScrollBehavior -> ScrollBehavior -> Bool
== :: ScrollBehavior -> ScrollBehavior -> Bool
$c/= :: ScrollBehavior -> ScrollBehavior -> Bool
/= :: ScrollBehavior -> ScrollBehavior -> Bool
Eq, Int -> ScrollBehavior -> ShowS
[ScrollBehavior] -> ShowS
ScrollBehavior -> String
(Int -> ScrollBehavior -> ShowS)
-> (ScrollBehavior -> String)
-> ([ScrollBehavior] -> ShowS)
-> Show ScrollBehavior
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScrollBehavior -> ShowS
showsPrec :: Int -> ScrollBehavior -> ShowS
$cshow :: ScrollBehavior -> String
show :: ScrollBehavior -> String
$cshowList :: [ScrollBehavior] -> ShowS
showList :: [ScrollBehavior] -> ShowS
Show)

-- | Where a widget ends up in the viewport once it is scrolled into view.
data ScrollAlign
  = -- | Move as little as possible: nothing at all when it is already whole.
    ScrollNearest
  | -- | Against the leading edge, at the top or left.
    ScrollStart
  | ScrollCenter
  | -- | Against the trailing edge, at the bottom or right.
    ScrollEnd
  deriving (ScrollAlign -> ScrollAlign -> Bool
(ScrollAlign -> ScrollAlign -> Bool)
-> (ScrollAlign -> ScrollAlign -> Bool) -> Eq ScrollAlign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScrollAlign -> ScrollAlign -> Bool
== :: ScrollAlign -> ScrollAlign -> Bool
$c/= :: ScrollAlign -> ScrollAlign -> Bool
/= :: ScrollAlign -> ScrollAlign -> Bool
Eq, Int -> ScrollAlign -> ShowS
[ScrollAlign] -> ShowS
ScrollAlign -> String
(Int -> ScrollAlign -> ShowS)
-> (ScrollAlign -> String)
-> ([ScrollAlign] -> ShowS)
-> Show ScrollAlign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScrollAlign -> ShowS
showsPrec :: Int -> ScrollAlign -> ShowS
$cshow :: ScrollAlign -> String
show :: ScrollAlign -> String
$cshowList :: [ScrollAlign] -> ShowS
showList :: [ScrollAlign] -> ShowS
Show)

-- | Scroll to an absolute offset, clamped to the scroller's range.
scrollTo :: Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()
scrollTo :: Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()
scrollTo Context
ctx WidgetId
wid V2
off ScrollBehavior
behavior =
  Context -> WidgetId -> (ScrollMetrics -> IO ()) -> IO ()
withScrollMetrics Context
ctx WidgetId
wid ((ScrollMetrics -> IO ()) -> IO ())
-> (ScrollMetrics -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScrollMetrics
m ->
    Context -> WidgetId -> ScrollAxes -> V2 -> ScrollBehavior -> IO ()
applyScrollTarget Context
ctx WidgetId
wid (ScrollMetrics -> ScrollAxes
scrollAxes ScrollMetrics
m) (V2 -> V2 -> V2
clampScrollOffset (ScrollMetrics -> V2
scrollRange ScrollMetrics
m) V2
off) ScrollBehavior
behavior

-- | Scroll by a delta in pixels. Deltas accumulate onto a glide already in
-- flight, so repeated calls keep up rather than fighting each other.
scrollBy :: Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()
scrollBy :: Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()
scrollBy Context
ctx WidgetId
wid V2
delta ScrollBehavior
behavior =
  Context -> WidgetId -> (ScrollMetrics -> IO ()) -> IO ()
withScrollMetrics Context
ctx WidgetId
wid ((ScrollMetrics -> IO ()) -> IO ())
-> (ScrollMetrics -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScrollMetrics
m -> Context
-> WidgetId -> ScrollMetrics -> V2 -> ScrollBehavior -> IO ()
scrollMetricsBy Context
ctx WidgetId
wid ScrollMetrics
m V2
delta ScrollBehavior
behavior

-- | Scroll by whole viewports: @V2 0 1@ is one page down, @V2 0 (-0.5)@ half
-- a page up.
scrollPages :: Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()
scrollPages :: Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()
scrollPages Context
ctx WidgetId
wid (V2 Float
px Float
py) ScrollBehavior
behavior =
  Context -> WidgetId -> (ScrollMetrics -> IO ()) -> IO ()
withScrollMetrics Context
ctx WidgetId
wid ((ScrollMetrics -> IO ()) -> IO ())
-> (ScrollMetrics -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScrollMetrics
m -> do
    let Rect Float
_ Float
_ Float
vw Float
vh = ScrollMetrics -> Rect
scrollViewport ScrollMetrics
m
    Context
-> WidgetId -> ScrollMetrics -> V2 -> ScrollBehavior -> IO ()
scrollMetricsBy Context
ctx WidgetId
wid ScrollMetrics
m (Float -> Float -> V2
V2 (Float
px Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
vw) (Float
py Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
vh)) ScrollBehavior
behavior

scrollMetricsBy :: Context -> WidgetId -> ScrollMetrics -> V2 -> ScrollBehavior -> IO ()
scrollMetricsBy :: Context
-> WidgetId -> ScrollMetrics -> V2 -> ScrollBehavior -> IO ()
scrollMetricsBy Context
ctx WidgetId
wid ScrollMetrics
m (V2 Float
dx Float
dy) ScrollBehavior
behavior = do
  V2 bx by <- Context -> WidgetId -> V2 -> IO V2
scrollTargetOffset Context
ctx WidgetId
wid (ScrollMetrics -> V2
scrollOffset ScrollMetrics
m)
  applyScrollTarget ctx wid (scrollAxes m) (clampScrollOffset (scrollRange m) (V2 (bx + dx) (by + dy))) behavior

-- | Scroll back to the top (and left).
scrollToStart :: Context -> WidgetId -> ScrollBehavior -> IO ()
scrollToStart :: Context -> WidgetId -> ScrollBehavior -> IO ()
scrollToStart Context
ctx WidgetId
wid = Context -> WidgetId -> V2 -> ScrollBehavior -> IO ()
scrollTo Context
ctx WidgetId
wid (Float -> Float -> V2
V2 Float
0 Float
0)

-- | Scroll to the end of the content.
scrollToEnd :: Context -> WidgetId -> ScrollBehavior -> IO ()
scrollToEnd :: Context -> WidgetId -> ScrollBehavior -> IO ()
scrollToEnd Context
ctx WidgetId
wid ScrollBehavior
behavior =
  Context -> WidgetId -> (ScrollMetrics -> IO ()) -> IO ()
withScrollMetrics Context
ctx WidgetId
wid ((ScrollMetrics -> IO ()) -> IO ())
-> (ScrollMetrics -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScrollMetrics
m ->
    Context -> WidgetId -> ScrollAxes -> V2 -> ScrollBehavior -> IO ()
applyScrollTarget Context
ctx WidgetId
wid (ScrollMetrics -> ScrollAxes
scrollAxes ScrollMetrics
m) (ScrollMetrics -> V2
scrollRange ScrollMetrics
m) ScrollBehavior
behavior

-- | Scroll @target@ into the viewport of the scroller @wid@ it is built
-- inside. Both widgets are read from the last frame's layout, so a widget
-- that was not built then, such as a row a virtualized list left out, cannot
-- be found; scroll to its content rectangle with 'scrollRectIntoView' instead.
scrollIntoView :: Context -> WidgetId -> WidgetId -> ScrollAlign -> ScrollBehavior -> IO ()
scrollIntoView :: Context
-> WidgetId -> WidgetId -> ScrollAlign -> ScrollBehavior -> IO ()
scrollIntoView Context
ctx WidgetId
wid WidgetId
target ScrollAlign
align ScrollBehavior
behavior = do
  mMetrics <- Context -> WidgetId -> IO (Maybe ScrollMetrics)
getScrollMetrics Context
ctx WidgetId
wid
  mRect <- getPrevRect ctx target
  case (mMetrics, mRect) of
    (Just ScrollMetrics
m, Just (Rect Float
rx Float
ry Float
rw Float
rh)) -> do
      let Rect Float
vx Float
vy Float
_ Float
_ = ScrollMetrics -> Rect
scrollViewport ScrollMetrics
m
          V2 Float
ox Float
oy = ScrollMetrics -> V2
scrollOffset ScrollMetrics
m
      Context
-> WidgetId -> Rect -> ScrollAlign -> ScrollBehavior -> IO ()
scrollRectIntoView Context
ctx WidgetId
wid (Float -> Float -> Float -> Float -> Rect
Rect (Float
rx Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vx Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
ox) (Float
ry Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
vy Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
oy) Float
rw Float
rh) ScrollAlign
align ScrollBehavior
behavior
    (Maybe ScrollMetrics, Maybe Rect)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Scroll a rectangle of the content into view. The rectangle is in content
-- coordinates: the origin is where the content starts, which is where the
-- viewport shows it at offset @0@.
scrollRectIntoView :: Context -> WidgetId -> Rect -> ScrollAlign -> ScrollBehavior -> IO ()
scrollRectIntoView :: Context
-> WidgetId -> Rect -> ScrollAlign -> ScrollBehavior -> IO ()
scrollRectIntoView Context
ctx WidgetId
wid (Rect Float
rx Float
ry Float
rw Float
rh) ScrollAlign
align ScrollBehavior
behavior =
  Context -> WidgetId -> (ScrollMetrics -> IO ()) -> IO ()
withScrollMetrics Context
ctx WidgetId
wid ((ScrollMetrics -> IO ()) -> IO ())
-> (ScrollMetrics -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScrollMetrics
m -> do
    let Rect Float
_ Float
_ Float
vw Float
vh = ScrollMetrics -> Rect
scrollViewport ScrollMetrics
m
        V2 Float
ox Float
oy = ScrollMetrics -> V2
scrollOffset ScrollMetrics
m
        V2 Float
mx Float
my = ScrollMetrics -> V2
scrollRange ScrollMetrics
m
        target :: V2
target =
          Float -> Float -> V2
V2
            (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 Float
mx (ScrollAlign -> Float -> Float -> Float -> Float -> Float
alignAxis ScrollAlign
align Float
vw Float
rx Float
rw Float
ox))
            (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 Float
my (ScrollAlign -> Float -> Float -> Float -> Float -> Float
alignAxis ScrollAlign
align Float
vh Float
ry Float
rh Float
oy))
    Context -> WidgetId -> ScrollAxes -> V2 -> ScrollBehavior -> IO ()
applyScrollTarget Context
ctx WidgetId
wid (ScrollMetrics -> ScrollAxes
scrollAxes ScrollMetrics
m) V2
target ScrollBehavior
behavior

-- | Offset that puts a span of the content where @align@ asks for it.
alignAxis :: ScrollAlign -> Float -> Float -> Float -> Float -> Float
alignAxis :: ScrollAlign -> Float -> Float -> Float -> Float -> Float
alignAxis ScrollAlign
align Float
viewSize Float
start Float
size Float
cur =
  case ScrollAlign
align of
    ScrollAlign
ScrollStart -> Float
start
    ScrollAlign
ScrollEnd -> Float
start Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
size Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
viewSize
    ScrollAlign
ScrollCenter -> Float
start Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
size Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
viewSize) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
2
    ScrollAlign
ScrollNearest
      | Float
start Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
cur -> Float
start
      | Float
start Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
size Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
cur Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
viewSize -> Float -> Float -> Float
forall a. Ord a => a -> a -> a
min Float
start (Float
start Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
size Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
viewSize)
      | Bool
otherwise -> Float
cur

-- | Hold an offset inside @0@ and the scroller's range on each axis.
{-# INLINE clampScrollOffset #-}
clampScrollOffset :: V2 -> V2 -> V2
clampScrollOffset :: V2 -> V2 -> V2
clampScrollOffset (V2 Float
mx Float
my) (V2 Float
x Float
y) = Float -> Float -> V2
V2 (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 Float
mx Float
x) (Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 Float
my Float
y)

-- | Drop the axis a 1D scroller does not move on. A table's paired panes link
-- their cross offsets, so a vertical scroller can carry a horizontal offset it
-- does not own; a glide that watched it would never settle.
{-# INLINE projectAxes #-}
projectAxes :: ScrollAxes -> V2 -> V2
projectAxes :: ScrollAxes -> V2 -> V2
projectAxes ScrollAxes
axes (V2 Float
x Float
y) =
  case ScrollAxes
axes of
    ScrollAxes
ScrollAxisY -> Float -> Float -> V2
V2 Float
0 Float
y
    ScrollAxes
ScrollAxisX -> Float -> Float -> V2
V2 Float
x Float
0
    ScrollAxes
ScrollAxisXY -> Float -> Float -> V2
V2 Float
x Float
y

withScrollMetrics :: Context -> WidgetId -> (ScrollMetrics -> IO ()) -> IO ()
withScrollMetrics :: Context -> WidgetId -> (ScrollMetrics -> IO ()) -> IO ()
withScrollMetrics Context
ctx WidgetId
wid ScrollMetrics -> IO ()
act = Context -> WidgetId -> IO (Maybe ScrollMetrics)
getScrollMetrics Context
ctx WidgetId
wid IO (Maybe ScrollMetrics) -> (Maybe ScrollMetrics -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ScrollMetrics -> IO ()) -> Maybe ScrollMetrics -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ScrollMetrics -> IO ()
act

-- =============================================================================
-- Glide
-- =============================================================================

-- | Send a scroller to an offset in window axes, gliding if the caller asked
-- for it and the context is tuned for it. The target must already be clamped
-- to the scroller's range.
applyScrollTarget :: Context -> WidgetId -> ScrollAxes -> V2 -> ScrollBehavior -> IO ()
applyScrollTarget :: Context -> WidgetId -> ScrollAxes -> V2 -> ScrollBehavior -> IO ()
applyScrollTarget Context
ctx WidgetId
wid ScrollAxes
axes V2
target0 ScrollBehavior
behavior = do
  st <- IORef ScrollState -> IO ScrollState
forall a. IORef a -> IO a
readIORef (Context -> IORef ScrollState
ctxScrollState Context
ctx)
  let smooth = ScrollTuning -> Float
scrollSmoothTime (ScrollState -> ScrollTuning
ssTuning ScrollState
st)
      target = ScrollAxes -> V2 -> V2
projectAxes ScrollAxes
axes V2
target0
  if behavior == ScrollInstant || smooth <= 0
    then setScrollOffsetIn ctx wid axes target
    else do
      cur <- getScrollOffsetIn ctx wid axes
      if nearOffset (projectAxes axes cur) target
        then setScrollOffsetIn ctx wid axes target
        else
          writeIORef (ctxScrollState ctx) $!
            st {ssGlides = IM.insert (intKey wid) (ScrollGlide wid target axes) (ssGlides st)}

-- | Where the scroller is headed: the glide's target if one is in flight, and
-- @fallback@ (normally the current offset) if not. Deltas add onto this so
-- that notches arriving mid-glide are not swallowed.
scrollTargetOffset :: Context -> WidgetId -> V2 -> IO V2
scrollTargetOffset :: Context -> WidgetId -> V2 -> IO V2
scrollTargetOffset Context
ctx WidgetId
wid V2
fallback = do
  st <- IORef ScrollState -> IO ScrollState
forall a. IORef a -> IO a
readIORef (Context -> IORef ScrollState
ctxScrollState Context
ctx)
  pure (maybe fallback sgTarget (IM.lookup (intKey wid) (ssGlides st)))

scrollGliding :: Context -> WidgetId -> IO Bool
scrollGliding :: Context -> WidgetId -> IO Bool
scrollGliding Context
ctx WidgetId
wid =
  Int -> IntMap ScrollGlide -> Bool
forall a. Int -> IntMap a -> Bool
IM.member (WidgetId -> Int
intKey WidgetId
wid) (IntMap ScrollGlide -> Bool)
-> (ScrollState -> IntMap ScrollGlide) -> ScrollState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScrollState -> IntMap ScrollGlide
ssGlides (ScrollState -> Bool) -> IO ScrollState -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ScrollState -> IO ScrollState
forall a. IORef a -> IO a
readIORef (Context -> IORef ScrollState
ctxScrollState Context
ctx)

-- | Hold a glide in flight inside a range that has just been measured again.
-- Without this a list filtered down mid-glide coasts past its new end and
-- stops there, showing nothing, until something else scrolls it.
clampScrollGlide :: Context -> WidgetId -> V2 -> IO ()
clampScrollGlide :: Context -> WidgetId -> V2 -> IO ()
clampScrollGlide Context
ctx WidgetId
wid V2
range =
  IORef ScrollState -> (ScrollState -> ScrollState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef ScrollState
ctxScrollState Context
ctx) ((ScrollState -> ScrollState) -> IO ())
-> (ScrollState -> ScrollState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScrollState
st ->
    if IntMap ScrollGlide -> Bool
forall a. IntMap a -> Bool
IM.null (ScrollState -> IntMap ScrollGlide
ssGlides ScrollState
st)
      then ScrollState
st
      else ScrollState
st {ssGlides = IM.adjust clampGlide (intKey wid) (ssGlides st)}
  where
    clampGlide :: ScrollGlide -> ScrollGlide
clampGlide ScrollGlide
g = ScrollGlide
g {sgTarget = projectAxes (sgAxes g) (clampScrollOffset range (sgTarget g))}

cancelScrollGlide :: Context -> WidgetId -> IO ()
cancelScrollGlide :: Context -> WidgetId -> IO ()
cancelScrollGlide Context
ctx WidgetId
wid =
  IORef ScrollState -> (ScrollState -> ScrollState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef ScrollState
ctxScrollState Context
ctx) ((ScrollState -> ScrollState) -> IO ())
-> (ScrollState -> ScrollState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ScrollState
st ->
    if IntMap ScrollGlide -> Bool
forall a. IntMap a -> Bool
IM.null (ScrollState -> IntMap ScrollGlide
ssGlides ScrollState
st)
      then ScrollState
st
      else ScrollState
st {ssGlides = IM.delete (intKey wid) (ssGlides st)}

-- | Advance every glide by @dt@ seconds. Each one covers the same fraction of
-- what is left every second, so a long throw starts fast and eases in, and at
-- least a pixel a frame so a glide cannot stall on the pixel grid the offsets
-- snap to.
stepScrollGlides :: Context -> Float -> IO ()
stepScrollGlides :: Context -> Float -> IO ()
stepScrollGlides Context
ctx Float
dt = do
  st <- IORef ScrollState -> IO ScrollState
forall a. IORef a -> IO a
readIORef (Context -> IORef ScrollState
ctxScrollState Context
ctx)
  unless (IM.null (ssGlides st)) $ do
    let alpha = Float -> Float -> Float
glideAlpha (ScrollTuning -> Float
scrollSmoothTime (ScrollState -> ScrollTuning
ssTuning ScrollState
st)) Float
dt
    done <- mapM (stepGlide ctx alpha) (IM.toList (ssGlides st))
    let settled = [Int
k | (Int
k, Bool
True) <- [(Int, Bool)]
done]
    unless (null settled) $
      modifyIORef' (ctxScrollState ctx) $ \ScrollState
s ->
        ScrollState
s {ssGlides = foldr IM.delete (ssGlides s) settled}

-- | Fraction of the remaining distance a glide covers in @dt@ seconds.
-- 'scrollSmoothTime' is the time to cover all but a twentieth of it.
glideAlpha :: Float -> Float -> Float
glideAlpha :: Float -> Float -> Float
glideAlpha Float
smooth Float
dt
  | Float
smooth Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 Bool -> Bool -> Bool
|| Float
dt Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 = Float
1
  | Bool
otherwise = Float -> Float -> Float -> Float
forall a. Ord a => a -> a -> a -> a
clamp Float
0 Float
1 (Float
1 Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float -> Float
forall a. Floating a => a -> a
exp (Float -> Float
forall a. Num a => a -> a
negate (Float
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
dt Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
smooth)))

stepGlide :: Context -> Float -> (Int, ScrollGlide) -> IO (Int, Bool)
stepGlide :: Context -> Float -> (Int, ScrollGlide) -> IO (Int, Bool)
stepGlide Context
ctx Float
alpha (Int
key, ScrollGlide WidgetId
wid V2
target ScrollAxes
axes) = do
  cur <- ScrollAxes -> V2 -> V2
projectAxes ScrollAxes
axes (V2 -> V2) -> IO V2 -> IO V2
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> WidgetId -> ScrollAxes -> IO V2
getScrollOffsetIn Context
ctx WidgetId
wid ScrollAxes
axes
  let next = Float -> Float -> V2
V2 (Float -> Float -> Float
stepAxis (V2 -> Float
v2X V2
cur) (V2 -> Float
v2X V2
target)) (Float -> Float -> Float
stepAxis (V2 -> Float
v2Y V2
cur) (V2 -> Float
v2Y V2
target))
  writeScrollOffsetIn ctx wid axes next
  pure (key, nearOffset next target)
  where
    stepAxis :: Float -> Float -> Float
stepAxis Float
c Float
t
      | Float -> Float
forall a. Num a => a -> a
abs (Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
c) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
1 = Float
t
      | Bool
otherwise =
          let moved :: Float
moved = Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
+ (Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
c) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
alpha
           in if Float -> Float
forall a. Num a => a -> a
abs (Float
moved Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
c) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
1
                then Float
c Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float -> Float
forall a. Num a => a -> a
signum (Float
t Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
c)
                else Float
moved

nearOffset :: V2 -> V2 -> Bool
nearOffset :: V2 -> V2 -> Bool
nearOffset (V2 Float
ax Float
ay) (V2 Float
bx Float
by) = Float -> Float
forall a. Num a => a -> a
abs (Float
ax Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
bx) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0.01 Bool -> Bool -> Bool
&& Float -> Float
forall a. Num a => a -> a
abs (Float
ay Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
by) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0.01