-- | Per-widget animations: starting, ticking, settling and reading values.
module NanoUI.Context.Animation
  ( anyAnimating
  , getLiveAnimations
  , isAnimatingKey
  , takeAnimSettled
  , lookupAnimation
  , getAnimRectless
  , setAnimRectless
  , startAnimation
  , startAnimationEase
  , startAnimationEaseDelay
  , startSpring
  , setAnimationValue
  , tickAnimations
  , getAnimationValue
  , getAnimRest
  , pruneAnimRest
  ) where

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

import NanoUI.Animation
  ( Animation (..)
  , Ease (..)
  , SpringParams
  , animInProgress
  , animationValue
  , approxEq
  , easeSameSpec
  , springEps
  , stepAnim
  , writeRest
  )
import NanoUI.Context.Core (damageKey, getsDamage, markDirty)
import NanoUI.Context.Types (AnimationState (..), Context (..), DamageState (..), ScrollState (..), intKey)
import NanoUI.Id (WidgetId)
import NanoUI.Layout.Arena (getRect, lookupNodeByKey)
import NanoUI.Types (DamageBounds (..), defaultDamageSlop)

-- | Whether the frame loop has to keep drawing: an animation is running, or a
-- scroller is still gliding onto its target.
{-# INLINE anyAnimating #-}
anyAnimating :: Context -> IO Bool
anyAnimating :: Context -> IO Bool
anyAnimating Context
ctx = do
  anim <- AnimationState -> Bool
asAnyAnimating (AnimationState -> Bool) -> IO AnimationState -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)
  if anim
    then pure True
    else not . IM.null . ssGlides <$> readIORef (ctxScrollState ctx)

{-# INLINE getLiveAnimations #-}
getLiveAnimations :: Context -> IO (IntMap Animation)
getLiveAnimations :: Context -> IO (IntMap Animation)
getLiveAnimations Context
ctx = (Animation -> Bool) -> IntMap Animation -> IntMap Animation
forall a. (a -> Bool) -> IntMap a -> IntMap a
IM.filter Animation -> Bool
animInProgress (IntMap Animation -> IntMap Animation)
-> (AnimationState -> IntMap Animation)
-> AnimationState
-> IntMap Animation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnimationState -> IntMap Animation
asAnimations (AnimationState -> IntMap Animation)
-> IO AnimationState -> IO (IntMap Animation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)

-- | Whether the widget key has an animation in progress. Unlike
-- 'getLiveAnimations' this does not rebuild the animation map.
{-# INLINE isAnimatingKey #-}
isAnimatingKey :: Context -> Int -> IO Bool
isAnimatingKey :: Context -> Int -> IO Bool
isAnimatingKey Context
ctx Int
key =
  Bool -> (Animation -> Bool) -> Maybe Animation -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Animation -> Bool
animInProgress (Maybe Animation -> Bool)
-> (AnimationState -> Maybe Animation) -> AnimationState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntMap Animation -> Maybe Animation
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
key (IntMap Animation -> Maybe Animation)
-> (AnimationState -> IntMap Animation)
-> AnimationState
-> Maybe Animation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnimationState -> IntMap Animation
asAnimations (AnimationState -> Bool) -> IO AnimationState -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)

-- Consecutive frames each live animation has had no nonzero widget rect in the
-- arena. Maintained by 'NanoUI.Damage.updatePrevRects'; used by 'writeDamage'
-- to bound the DamageFull escalation for rect-less animations so a perpetual
-- animation whose widget left the arena (e.g. `keepAnimating` on a widget
-- hidden by a tab switch) stops repainting the whole window after a frame or
-- two, instead of forever.
{-# INLINE getAnimRectless #-}
getAnimRectless :: Context -> IO (IntMap Int)
getAnimRectless :: Context -> IO (IntMap Int)
getAnimRectless Context
ctx = AnimationState -> IntMap Int
asRectless (AnimationState -> IntMap Int)
-> IO AnimationState -> IO (IntMap Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)

{-# INLINE setAnimRectless #-}
setAnimRectless :: Context -> IntMap Int -> IO ()
setAnimRectless :: Context -> IntMap Int -> IO ()
setAnimRectless Context
ctx IntMap Int
m =
  IORef AnimationState -> (AnimationState -> AnimationState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef AnimationState
ctxAnimationState Context
ctx) ((AnimationState -> AnimationState) -> IO ())
-> (AnimationState -> AnimationState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AnimationState
as -> AnimationState
as {asRectless = m}

takeAnimSettled :: Context -> IO Bool
takeAnimSettled :: Context -> IO Bool
takeAnimSettled Context
ctx = do
  as <- IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)
  if asAnimSettled as
    then do
      writeIORef (ctxAnimationState ctx) $! as {asAnimSettled = False}
      pure True
    else pure False

{-# INLINE lookupAnimation #-}
lookupAnimation :: Context -> WidgetId -> IO (Maybe Animation)
lookupAnimation :: Context -> WidgetId -> IO (Maybe Animation)
lookupAnimation Context
ctx WidgetId
wid = Int -> IntMap Animation -> Maybe Animation
forall a. Int -> IntMap a -> Maybe a
IM.lookup (WidgetId -> Int
intKey WidgetId
wid) (IntMap Animation -> Maybe Animation)
-> (AnimationState -> IntMap Animation)
-> AnimationState
-> Maybe Animation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnimationState -> IntMap Animation
asAnimations (AnimationState -> Maybe Animation)
-> IO AnimationState -> IO (Maybe Animation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)

{-# INLINE startAnimation #-}
startAnimation :: Context -> WidgetId -> Float -> Float -> Float -> IO ()
startAnimation :: Context -> WidgetId -> Float -> Float -> Float -> IO ()
startAnimation Context
ctx WidgetId
wid Float
start Float
end Float
dur = Context -> WidgetId -> Float -> Float -> Float -> Ease -> IO ()
startAnimationEase Context
ctx WidgetId
wid Float
start Float
end Float
dur Ease
EaseLinear

{-# INLINE startAnimationEase #-}
startAnimationEase :: Context -> WidgetId -> Float -> Float -> Float -> Ease -> IO ()
startAnimationEase :: Context -> WidgetId -> Float -> Float -> Float -> Ease -> IO ()
startAnimationEase Context
ctx WidgetId
wid Float
start Float
end Float
dur Ease
ease = Context
-> WidgetId -> Float -> Float -> Float -> Ease -> Float -> IO ()
startAnimationEaseDelay Context
ctx WidgetId
wid Float
start Float
end Float
dur Ease
ease Float
0

startAnimationEaseDelay :: Context -> WidgetId -> Float -> Float -> Float -> Ease -> Float -> IO ()
startAnimationEaseDelay :: Context
-> WidgetId -> Float -> Float -> Float -> Ease -> Float -> IO ()
startAnimationEaseDelay Context
ctx WidgetId
wid Float
start Float
end Float
dur Ease
ease Float
delay
  | Float
dur Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0 Bool -> Bool -> Bool
|| Float -> Float -> Bool
approxEq Float
start Float
end = Context -> Int -> Float -> IO ()
settleKey Context
ctx Int
key Float
end
  | Bool
otherwise = do
      as <- IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)
      let req = Float -> Float -> Float
forall a. Ord a => a -> a -> a
max Float
0 Float
delay
      case IM.lookup key (asAnimations as) of
        Just a :: Animation
a@(EaseAnim Float
aStart Float
_ Float
_ Float
_ Ease
_ Float
_ Float
_) | Float -> Float -> Bool
approxEq Float
aStart Float
start Bool -> Bool -> Bool
&& Animation -> Ease -> Float -> Float -> Float -> Bool
easeSameSpec Animation
a Ease
ease Float
dur Float
req Float
end -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Maybe Animation
_ ->
          IORef AnimationState -> AnimationState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx) (AnimationState -> IO ()) -> AnimationState -> IO ()
forall a b. (a -> b) -> a -> b
$!
            AnimationState
as
              { asAnimRest = IM.delete key (asAnimRest as)
              , asAnimations = IM.insert key (EaseAnim start end dur 0 ease req req) (asAnimations as)
              , asAnyAnimating = True
              }
      markDirtyIfOrphan ctx key
  where
    key :: Int
key = WidgetId -> Int
intKey WidgetId
wid

startSpring :: Context -> WidgetId -> SpringParams -> Float -> IO ()
startSpring :: Context -> WidgetId -> SpringParams -> Float -> IO ()
startSpring Context
ctx WidgetId
wid SpringParams
params Float
target = do
  let key :: Int
key = WidgetId -> Int
intKey WidgetId
wid
  as <- IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)
  case IM.lookup key (asAnimations as) of
    Just (SpringAnim Float
_ Float
_ Float
t SpringParams
p) | Float
t Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
target Bool -> Bool -> Bool
&& SpringParams
p SpringParams -> SpringParams -> Bool
forall a. Eq a => a -> a -> Bool
== SpringParams
params -> Context -> Int -> IO ()
markDirtyIfOrphan Context
ctx Int
key
    Maybe Animation
running -> do
      let (Float
pos, Float
vel) = case Maybe Animation
running of
            Just (SpringAnim Float
p Float
v Float
_ SpringParams
_) -> (Float
p, Float
v)
            Just Animation
a -> (Animation -> Float
animationValue Animation
a, Float
0)
            Maybe Animation
Nothing -> (Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
key (AnimationState -> IntMap Float
asAnimRest AnimationState
as), Float
0)
      if Float -> Float
forall a. Num a => a -> a
abs (Float
pos Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
target) Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
springEps Bool -> Bool -> Bool
&& Float -> Float
forall a. Num a => a -> a
abs Float
vel Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
springEps
        then Context -> Int -> Float -> IO ()
settleKey Context
ctx Int
key Float
target
        else do
          IORef AnimationState -> AnimationState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx) (AnimationState -> IO ()) -> AnimationState -> IO ()
forall a b. (a -> b) -> a -> b
$!
            AnimationState
as
              { asAnimRest = IM.delete key (asAnimRest as)
              , asAnimations = IM.insert key (SpringAnim pos vel target params) (asAnimations as)
              , asAnyAnimating = True
              }
          Context -> Int -> IO ()
markDirtyIfOrphan Context
ctx Int
key

{-# INLINE setAnimationValue #-}
setAnimationValue :: Context -> WidgetId -> Float -> IO ()
setAnimationValue :: Context -> WidgetId -> Float -> IO ()
setAnimationValue Context
ctx WidgetId
wid Float
val = Context -> Int -> Float -> IO ()
settleKey Context
ctx (WidgetId -> Int
intKey WidgetId
wid) Float
val

tickAnimations :: Context -> Float -> IO ()
tickAnimations :: Context -> Float -> IO ()
tickAnimations Context
ctx Float
dt =
  IORef AnimationState -> (AnimationState -> AnimationState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef AnimationState
ctxAnimationState Context
ctx) ((AnimationState -> AnimationState) -> IO ())
-> (AnimationState -> AnimationState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AnimationState
as ->
    if IntMap Animation -> Bool
forall a. IntMap a -> Bool
IM.null (AnimationState -> IntMap Animation
asAnimations AnimationState
as)
      then AnimationState
as {asAnyAnimating = False, asAnimSettled = False}
      else
        let stepped :: IntMap Animation
stepped = (Animation -> Animation) -> IntMap Animation -> IntMap Animation
forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map (Float -> Animation -> Animation
stepAnim Float
dt) (AnimationState -> IntMap Animation
asAnimations AnimationState
as)
            (IntMap Animation
live, IntMap Animation
done) = (Animation -> Bool)
-> IntMap Animation -> (IntMap Animation, IntMap Animation)
forall a. (a -> Bool) -> IntMap a -> (IntMap a, IntMap a)
IM.partition Animation -> Bool
animInProgress IntMap Animation
stepped
            rest' :: IntMap Float
rest' = (IntMap Float -> Int -> Animation -> IntMap Float)
-> IntMap Float -> IntMap Animation -> IntMap Float
forall a b. (a -> Int -> b -> a) -> a -> IntMap b -> a
IM.foldlWithKey' IntMap Float -> Int -> Animation -> IntMap Float
writeRest (AnimationState -> IntMap Float
asAnimRest AnimationState
as) IntMap Animation
done
         in AnimationState
as
              { asAnimations = live
              , asAnimRest = rest'
              , asAnyAnimating = not (IM.null live)
              , asAnimSettled = not (IM.null done)
              }

markDirtyIfOrphan :: Context -> Int -> IO ()
markDirtyIfOrphan :: Context -> Int -> IO ()
markDirtyIfOrphan Context
ctx Int
key = do
  hadRect <- Int -> IntMap Rect -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
key (IntMap Rect -> Bool) -> IO (IntMap Rect) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> (DamageState -> IntMap Rect) -> IO (IntMap Rect)
forall a. Context -> (DamageState -> a) -> IO a
getsDamage Context
ctx DamageState -> IntMap Rect
dsPrevRects
  hasNow <- nodeHasKey ctx key
  unless (hadRect || hasNow) (markDirty ctx)

nodeHasKey :: Context -> Int -> IO Bool
nodeHasKey :: Context -> Int -> IO Bool
nodeHasKey Context
ctx Int
key = do
  mIdx <- NodeArena -> Int -> IO (Maybe Int)
lookupNodeByKey (Context -> NodeArena
ctxNodeArena Context
ctx) Int
key
  case mIdx of
    Maybe Int
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Just Int
idx -> do
      (_, _, w, h) <- NodeArena -> Int -> IO (Float, Float, Float, Float)
getRect (Context -> NodeArena
ctxNodeArena Context
ctx) Int
idx
      pure (w > 0 && h > 0)

settleKey :: Context -> Int -> Float -> IO ()
settleKey :: Context -> Int -> Float -> IO ()
settleKey Context
ctx Int
key Float
val = do
  as <- IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)
  let rest = AnimationState -> IntMap Float
asAnimRest AnimationState
as
      prevRest = Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
key IntMap Float
rest
      prevLive = Int -> IntMap Animation -> Maybe Animation
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
key (AnimationState -> IntMap Animation
asAnimations AnimationState
as)
      restChanged
        | Float -> Float -> Bool
approxEq Float
val Float
0 = Int -> IntMap Float -> Bool
forall a. Int -> IntMap a -> Bool
IM.member Int
key IntMap Float
rest
        | Bool
otherwise = Float
prevRest Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
/= Float
val
      rest'
        | Bool -> Bool
not Bool
restChanged = IntMap Float
rest
        | Float -> Float -> Bool
approxEq Float
val Float
0 = Int -> IntMap Float -> IntMap Float
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
key IntMap Float
rest
        | Bool
otherwise = Int -> Float -> IntMap Float -> IntMap Float
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
key Float
val IntMap Float
rest
  -- A spring at rest settles every frame; write only what changes.
  case prevLive of
    Just Animation
_ -> do
      let anims' :: IntMap Animation
anims' = Int -> IntMap Animation -> IntMap Animation
forall a. Int -> IntMap a -> IntMap a
IM.delete Int
key (AnimationState -> IntMap Animation
asAnimations AnimationState
as)
      IORef AnimationState -> AnimationState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx) (AnimationState -> IO ()) -> AnimationState -> IO ()
forall a b. (a -> b) -> a -> b
$!
        AnimationState
as {asAnimations = anims', asAnimRest = rest', asAnyAnimating = not (IM.null anims')}
    Maybe Animation
Nothing -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
restChanged (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef AnimationState -> AnimationState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx) (AnimationState -> IO ()) -> AnimationState -> IO ()
forall a b. (a -> b) -> a -> b
$! AnimationState
as {asAnimRest = rest'}
  when (maybe (not (approxEq prevRest val)) (not . approxEq val . animationValue) prevLive) $ do
    damageKey ctx key (DamageInflated defaultDamageSlop)
    markDirty ctx

getAnimationValue :: Context -> WidgetId -> IO Float
getAnimationValue :: Context -> WidgetId -> IO Float
getAnimationValue Context
ctx WidgetId
wid = do
  let key :: Int
key = WidgetId -> Int
intKey WidgetId
wid
  as <- IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)
  case IM.lookup key (asAnimations as) of
    Just Animation
a -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> IO Float) -> Float -> IO Float
forall a b. (a -> b) -> a -> b
$! Animation -> Float
animationValue Animation
a
    Maybe Animation
Nothing -> Float -> IO Float
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Float -> IO Float) -> Float -> IO Float
forall a b. (a -> b) -> a -> b
$! Float -> Int -> IntMap Float -> Float
forall a. a -> Int -> IntMap a -> a
IM.findWithDefault Float
0 Int
key (AnimationState -> IntMap Float
asAnimRest AnimationState
as)

{-# INLINE getAnimRest #-}
getAnimRest :: Context -> IO (IntMap Float)
getAnimRest :: Context -> IO (IntMap Float)
getAnimRest Context
ctx = AnimationState -> IntMap Float
asAnimRest (AnimationState -> IntMap Float)
-> IO AnimationState -> IO (IntMap Float)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AnimationState -> IO AnimationState
forall a. IORef a -> IO a
readIORef (Context -> IORef AnimationState
ctxAnimationState Context
ctx)

{-# INLINE pruneAnimRest #-}
pruneAnimRest :: Context -> (Int -> Bool) -> IO ()
pruneAnimRest :: Context -> (Int -> Bool) -> IO ()
pruneAnimRest Context
ctx Int -> Bool
shouldKeep =
  IORef AnimationState -> (AnimationState -> AnimationState) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (Context -> IORef AnimationState
ctxAnimationState Context
ctx) ((AnimationState -> AnimationState) -> IO ())
-> (AnimationState -> AnimationState) -> IO ()
forall a b. (a -> b) -> a -> b
$ \AnimationState
as ->
    AnimationState
as {asAnimRest = IM.filterWithKey (\Int
k Float
_ -> Int -> Bool
shouldKeep Int
k) (asAnimRest as)}