content: {-|
  Module      : Monomer.Widgets.Animation.Transform
  Copyright   : (c) 2023 Ruslan Gadeev, Francisco Vallarino
  License     : BSD-3-Clause (see the LICENSE file)
  Maintainer  : fjvallarino@gmail.com
  Stability   : experimental
  Portability : non-portable
  
  Transform animation widget. Wraps a child widget whose content will be animated.
  Acts as a base for most animation widgets.
  
  Messages:
  
  - Accepts an 'AnimationMsg', used to control the state of the animation.
  
  @
  transform t (Rect x y w h) =
    [ animTranslation $ Point tx ty
    , animScale $ Point sx sy
    ]
  
  animTransform transform managed
  @
  
  With configuration options:
  
  @
  transform t (Rect x y w h) =
    [ animTranslation $ Point tx ty
    , animScale $ Point sx sy
    ]
  
  animTransform_ [duration 2000, autoStart] transform managed
  @
  
  For usage examples, see:
  
  - "Monomer.Widgets.Animation.Shake"
  - "Monomer.Widgets.Animation.Zoom"
  -}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE Strict #-}
  
  module Monomer.Widgets.Animation.Transform (
    -- * Configuration
    TransformCfg(..),
    -- * Render transformations
    RenderTransform,
    animTranslation,
    animScale,
    animRotation,
    animGlobalAlpha,
    animScissor,
    -- * Constructors
    animTransform,
    animTransform_
  ) where
  
  import Control.Applicative ((<|>))
  import Control.Lens ((&), (^.), (.~))
  import Control.Monad (when)
  import Data.Default
  import Data.Maybe
  import Data.Typeable (cast)
  import GHC.Generics
  
  import qualified Data.Sequence as Seq
  
  import Monomer.Helper
  import Monomer.Widgets.Container
  import Monomer.Widgets.Animation.Types
  
  import qualified Monomer.Lens as L
  
  {-|
  Configuration options for transform:
  
  - 'autoStart': whether the first time the widget is added, animation should run.
  - 'duration': how long the animation lasts in ms.
  - 'onFinished': event to raise when animation is complete.
  - 'onFinishedReq': 'WidgetRequest' to generate when animation is complete.
  -}
  data TransformCfg s e = TransformCfg {
    _tfcAutoStart :: Maybe Bool,
    _tfcDuration :: Maybe Millisecond,
    _tfcOnFinishedReq :: [WidgetRequest s e]
  } deriving (Eq, Show)
  
  instance Default (TransformCfg s e) where
    def = TransformCfg {
      _tfcAutoStart = Nothing,
      _tfcDuration = Nothing,
      _tfcOnFinishedReq = []
    }
  
  instance Semigroup (TransformCfg s e) where
    (<>) tc1 tc2 = TransformCfg {
      _tfcAutoStart = _tfcAutoStart tc2 <|> _tfcAutoStart tc1,
      _tfcDuration = _tfcDuration tc2 <|> _tfcDuration tc1,
      _tfcOnFinishedReq = _tfcOnFinishedReq tc1 <> _tfcOnFinishedReq tc2
    }
  
  instance Monoid (TransformCfg s e) where
    mempty = def
  
  instance CmbAutoStart (TransformCfg s e) where
    autoStart_ start = def {
      _tfcAutoStart = Just start
    }
  
  instance CmbDuration (TransformCfg s e) Millisecond where
    duration dur = def {
      _tfcDuration = Just dur
    }
  
  instance WidgetEvent e => CmbOnFinished (TransformCfg s e) e where
    onFinished handler = def {
      _tfcOnFinishedReq = [RaiseEvent handler]
    }
  
  instance CmbOnFinishedReq (TransformCfg s e) s e where
    onFinishedReq req = def {
      _tfcOnFinishedReq = [req]
    }
  
  data TransformState = TransformState {
    _tfsRunning :: Bool,
    _tfsStartTs :: Millisecond
  } deriving (Eq, Show, Generic)
  
  instance Default TransformState where
    def = TransformState {
      _tfsRunning = False,
      _tfsStartTs = 0
    }
  
  {-|
  Possible render transformations:
  
  - 'animTranslation': translates by the given offset.
  - 'animScale': scales by the given size.
  - 'animRotation': rotates by the given angle.
  - 'animGlobalAlpha': applies the given alpha.
  - 'animScissor': scissors to the given viewport.
  -}
  data RenderTransform = RenderTransform {
    _rtTranslation :: Maybe Point,
    _rtScale :: Maybe Point,
    _rtRotation :: Maybe Double,
    _rtGlobalAlpha :: Maybe Double,
    _rtScissor :: Maybe Rect
  }
  
  instance Default RenderTransform where
    def = RenderTransform {
      _rtTranslation = Nothing,
      _rtScale = Nothing,
      _rtRotation = Nothing,
      _rtGlobalAlpha = Nothing,
      _rtScissor = Nothing
    }
  
  instance Semigroup RenderTransform where
    (<>) rt1 rt2 = RenderTransform {
      _rtTranslation = _rtTranslation rt2 <|> _rtTranslation rt1,
      _rtScale = _rtScale rt2 <|> _rtScale rt1,
      _rtRotation = _rtRotation rt2 <|> _rtRotation rt1,
      _rtGlobalAlpha = _rtGlobalAlpha rt2 <|> _rtGlobalAlpha rt1,
      _rtScissor = _rtScissor rt2 <|> _rtScissor rt1
    }
  
  instance Monoid RenderTransform where
    mempty = def
  
  -- | Translate by the given offset.
  animTranslation :: Point -> RenderTransform
  animTranslation p = def { _rtTranslation = Just p }
  
  -- | Scale by the given size.
  animScale :: Point -> RenderTransform
  animScale p = def { _rtScale = Just p }
  
  -- | Rotate by the given angle.
  animRotation :: Double -> RenderTransform
  animRotation r = def { _rtRotation = Just r }
  
  -- | Apply the given alpha.
  animGlobalAlpha :: Double -> RenderTransform
  animGlobalAlpha a = def { _rtGlobalAlpha = Just a }
  
  -- | Scissor to the given viewport.
  animScissor :: Rect -> RenderTransform
  animScissor vp = def { _rtScissor = Just vp }
  
  type Transformer = (Double -> Rect -> [RenderTransform])
  
  -- | Animates a widget through translation, scaling, rotation,
  --   transparency and scissor.
  animTransform
    :: WidgetEvent e
    => Transformer     -- ^ Transformations from time (in ms) and viewport.
    -> WidgetNode s e  -- ^ The child node.
    -> WidgetNode s e  -- ^ The created animation container.
  animTransform f managed = animTransform_ def f managed
  
  -- | Animates a widget through translation, scaling, rotation,
  --   transparency and scissor. Accepts config.
  animTransform_
    :: WidgetEvent e
    => [TransformCfg s e]  -- ^ The config options.
    -> Transformer         -- ^ Transformations from time (in ms) and viewport.
    -> WidgetNode s e      -- ^ The child node.
    -> WidgetNode s e      -- ^ The created animation container.
  animTransform_ configs f managed = node where
    node = defaultWidgetNode widgetType widget
      & L.info . L.focusable .~ False
      & L.children .~ Seq.singleton managed
    widgetType = WidgetType "animTransform"
    widget = makeTransform f config def
    config = mconcat configs
  
  makeTransform
    :: WidgetEvent e
    => Transformer
    -> TransformCfg s e
    -> TransformState
    -> Widget s e
  makeTransform f config state = widget where
    baseWidget = createContainer state def {
      containerInit = init,
      containerMerge = merge,
      containerHandleMessage = handleMessage
    }
    widget = baseWidget {
      widgetRender = render
    }
  
    TransformCfg{..} = config
    TransformState{..} = state
    autoStart = fromMaybe False _tfcAutoStart
    duration = fromMaybe 500 _tfcDuration
    period = 20
    steps = fromIntegral $ duration `div` period
  
    finishedReq node ts = delayedMessage node (AnimationFinished ts) duration
    renderReq wenv node = req where
      widgetId = node ^. L.info . L.widgetId
      req = RenderEvery widgetId period (Just steps)
  
    init wenv node = result where
      ts = wenv ^. L.timestamp
      newNode = node
        & L.widget .~ makeTransform f config (TransformState True ts)
      result
        | autoStart = resultReqs newNode [finishedReq node ts, renderReq wenv node]
        | otherwise = resultNode node
  
    merge wenv node oldNode oldState = resultNode newNode where
      newNode = node
        & L.widget .~ makeTransform f config oldState
  
    handleMessage wenv node target message = result where
      result = cast message >>= Just . handleAnimateMsg wenv node
  
    handleAnimateMsg wenv node msg = result where
      widgetId = node ^. L.info . L.widgetId
      ts = wenv ^. L.timestamp
      startState = TransformState True ts
      startReqs = [finishedReq node ts, renderReq wenv node]
  
      newNode newState = node
        & L.widget .~ makeTransform f config newState
      result = case msg of
        AnimationStart -> resultReqs (newNode startState) startReqs
        AnimationStop -> resultReqs (newNode def) [RenderStop widgetId]
        AnimationFinished ts'
          | isRelevant -> resultReqs node _tfcOnFinishedReq
          | otherwise -> resultNode node
          where isRelevant = _tfsRunning && ts' == _tfsStartTs
  
    render wenv node renderer = do
      if _tfsRunning
        then createOverlay renderer $ do
          saveContext renderer
          setTranslation renderer $ wenv ^. L.offset
          intersectScissor renderer scissorViewport
          setTranslation renderer $ Point (x+w/2) (y+h/2)
          setRotation renderer rotation
          setTranslation renderer $ Point (-x-w/2) (-y-h/2)
          setTranslation renderer $ Point (tx+x*(1-sx)) (ty+y*(1-sy))
          setScale renderer scale
          setGlobalAlpha renderer alpha
          widgetRender (cnode ^. L.widget) wenv cnode renderer
          restoreContext renderer
        else widgetRender (cnode ^. L.widget) wenv cnode renderer
      where
        vp@(Rect x y w h) = node ^. L.info . L.viewport
        t = clamp 0 duration $ (wenv ^. L.timestamp) - _tfsStartTs
        RenderTransform{..} = mconcat $ f (fromIntegral t) vp
        Point tx ty = fromMaybe (Point 0 0) _rtTranslation
        scale@(Point sx sy) = fromMaybe (Point 1 1) _rtScale
        rotation = fromMaybe 0 _rtRotation
        alpha = fromMaybe 1 _rtGlobalAlpha
        scissorViewport = fromMaybe vp _rtScissor
        cnode = Seq.index (node ^. L.children) 0
  