{-|
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 {
  forall s e. TransformCfg s e -> Maybe Bool
_tfcAutoStart :: Maybe Bool,
  forall s e. TransformCfg s e -> Maybe Millisecond
_tfcDuration :: Maybe Millisecond,
  forall s e. TransformCfg s e -> [WidgetRequest s e]
_tfcOnFinishedReq :: [WidgetRequest s e]
} deriving (TransformCfg s e -> TransformCfg s e -> Bool
(TransformCfg s e -> TransformCfg s e -> Bool)
-> (TransformCfg s e -> TransformCfg s e -> Bool)
-> Eq (TransformCfg s e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s e. Eq e => TransformCfg s e -> TransformCfg s e -> Bool
$c== :: forall s e. Eq e => TransformCfg s e -> TransformCfg s e -> Bool
== :: TransformCfg s e -> TransformCfg s e -> Bool
$c/= :: forall s e. Eq e => TransformCfg s e -> TransformCfg s e -> Bool
/= :: TransformCfg s e -> TransformCfg s e -> Bool
Eq, Int -> TransformCfg s e -> ShowS
[TransformCfg s e] -> ShowS
TransformCfg s e -> String
(Int -> TransformCfg s e -> ShowS)
-> (TransformCfg s e -> String)
-> ([TransformCfg s e] -> ShowS)
-> Show (TransformCfg s e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s e. Int -> TransformCfg s e -> ShowS
forall s e. [TransformCfg s e] -> ShowS
forall s e. TransformCfg s e -> String
$cshowsPrec :: forall s e. Int -> TransformCfg s e -> ShowS
showsPrec :: Int -> TransformCfg s e -> ShowS
$cshow :: forall s e. TransformCfg s e -> String
show :: TransformCfg s e -> String
$cshowList :: forall s e. [TransformCfg s e] -> ShowS
showList :: [TransformCfg s e] -> ShowS
Show)

instance Default (TransformCfg s e) where
  def :: TransformCfg s e
def = TransformCfg {
    _tfcAutoStart :: Maybe Bool
_tfcAutoStart = Maybe Bool
forall a. Maybe a
Nothing,
    _tfcDuration :: Maybe Millisecond
_tfcDuration = Maybe Millisecond
forall a. Maybe a
Nothing,
    _tfcOnFinishedReq :: [WidgetRequest s e]
_tfcOnFinishedReq = []
  }

instance Semigroup (TransformCfg s e) where
  <> :: TransformCfg s e -> TransformCfg s e -> TransformCfg s e
(<>) TransformCfg s e
tc1 TransformCfg s e
tc2 = TransformCfg {
    _tfcAutoStart :: Maybe Bool
_tfcAutoStart = TransformCfg s e -> Maybe Bool
forall s e. TransformCfg s e -> Maybe Bool
_tfcAutoStart TransformCfg s e
tc2 Maybe Bool -> Maybe Bool -> Maybe Bool
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TransformCfg s e -> Maybe Bool
forall s e. TransformCfg s e -> Maybe Bool
_tfcAutoStart TransformCfg s e
tc1,
    _tfcDuration :: Maybe Millisecond
_tfcDuration = TransformCfg s e -> Maybe Millisecond
forall s e. TransformCfg s e -> Maybe Millisecond
_tfcDuration TransformCfg s e
tc2 Maybe Millisecond -> Maybe Millisecond -> Maybe Millisecond
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TransformCfg s e -> Maybe Millisecond
forall s e. TransformCfg s e -> Maybe Millisecond
_tfcDuration TransformCfg s e
tc1,
    _tfcOnFinishedReq :: [WidgetRequest s e]
_tfcOnFinishedReq = TransformCfg s e -> [WidgetRequest s e]
forall s e. TransformCfg s e -> [WidgetRequest s e]
_tfcOnFinishedReq TransformCfg s e
tc1 [WidgetRequest s e] -> [WidgetRequest s e] -> [WidgetRequest s e]
forall a. Semigroup a => a -> a -> a
<> TransformCfg s e -> [WidgetRequest s e]
forall s e. TransformCfg s e -> [WidgetRequest s e]
_tfcOnFinishedReq TransformCfg s e
tc2
  }

instance Monoid (TransformCfg s e) where
  mempty :: TransformCfg s e
mempty = TransformCfg s e
forall a. Default a => a
def

instance CmbAutoStart (TransformCfg s e) where
  autoStart_ :: Bool -> TransformCfg s e
autoStart_ Bool
start = TransformCfg s e
forall a. Default a => a
def {
    _tfcAutoStart = Just start
  }

instance CmbDuration (TransformCfg s e) Millisecond where
  duration :: Millisecond -> TransformCfg s e
duration Millisecond
dur = TransformCfg s e
forall a. Default a => a
def {
    _tfcDuration = Just dur
  }

instance WidgetEvent e => CmbOnFinished (TransformCfg s e) e where
  onFinished :: e -> TransformCfg s e
onFinished e
handler = TransformCfg Any Any
forall a. Default a => a
def {
    _tfcOnFinishedReq = [RaiseEvent handler]
  }

instance CmbOnFinishedReq (TransformCfg s e) s e where
  onFinishedReq :: WidgetRequest s e -> TransformCfg s e
onFinishedReq WidgetRequest s e
req = TransformCfg Any Any
forall a. Default a => a
def {
    _tfcOnFinishedReq = [req]
  }

data TransformState = TransformState {
  TransformState -> Bool
_tfsRunning :: Bool,
  TransformState -> Millisecond
_tfsStartTs :: Millisecond
} deriving (TransformState -> TransformState -> Bool
(TransformState -> TransformState -> Bool)
-> (TransformState -> TransformState -> Bool) -> Eq TransformState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransformState -> TransformState -> Bool
== :: TransformState -> TransformState -> Bool
$c/= :: TransformState -> TransformState -> Bool
/= :: TransformState -> TransformState -> Bool
Eq, Int -> TransformState -> ShowS
[TransformState] -> ShowS
TransformState -> String
(Int -> TransformState -> ShowS)
-> (TransformState -> String)
-> ([TransformState] -> ShowS)
-> Show TransformState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransformState -> ShowS
showsPrec :: Int -> TransformState -> ShowS
$cshow :: TransformState -> String
show :: TransformState -> String
$cshowList :: [TransformState] -> ShowS
showList :: [TransformState] -> ShowS
Show, (forall x. TransformState -> Rep TransformState x)
-> (forall x. Rep TransformState x -> TransformState)
-> Generic TransformState
forall x. Rep TransformState x -> TransformState
forall x. TransformState -> Rep TransformState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TransformState -> Rep TransformState x
from :: forall x. TransformState -> Rep TransformState x
$cto :: forall x. Rep TransformState x -> TransformState
to :: forall x. Rep TransformState x -> TransformState
Generic)

instance Default TransformState where
  def :: TransformState
def = TransformState {
    _tfsRunning :: Bool
_tfsRunning = Bool
False,
    _tfsStartTs :: Millisecond
_tfsStartTs = Millisecond
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 {
  RenderTransform -> Maybe Point
_rtTranslation :: Maybe Point,
  RenderTransform -> Maybe Point
_rtScale :: Maybe Point,
  RenderTransform -> Maybe Double
_rtRotation :: Maybe Double,
  RenderTransform -> Maybe Double
_rtGlobalAlpha :: Maybe Double,
  RenderTransform -> Maybe Rect
_rtScissor :: Maybe Rect
}

instance Default RenderTransform where
  def :: RenderTransform
def = RenderTransform {
    _rtTranslation :: Maybe Point
_rtTranslation = Maybe Point
forall a. Maybe a
Nothing,
    _rtScale :: Maybe Point
_rtScale = Maybe Point
forall a. Maybe a
Nothing,
    _rtRotation :: Maybe Double
_rtRotation = Maybe Double
forall a. Maybe a
Nothing,
    _rtGlobalAlpha :: Maybe Double
_rtGlobalAlpha = Maybe Double
forall a. Maybe a
Nothing,
    _rtScissor :: Maybe Rect
_rtScissor = Maybe Rect
forall a. Maybe a
Nothing
  }

instance Semigroup RenderTransform where
  <> :: RenderTransform -> RenderTransform -> RenderTransform
(<>) RenderTransform
rt1 RenderTransform
rt2 = RenderTransform {
    _rtTranslation :: Maybe Point
_rtTranslation = RenderTransform -> Maybe Point
_rtTranslation RenderTransform
rt2 Maybe Point -> Maybe Point -> Maybe Point
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RenderTransform -> Maybe Point
_rtTranslation RenderTransform
rt1,
    _rtScale :: Maybe Point
_rtScale = RenderTransform -> Maybe Point
_rtScale RenderTransform
rt2 Maybe Point -> Maybe Point -> Maybe Point
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RenderTransform -> Maybe Point
_rtScale RenderTransform
rt1,
    _rtRotation :: Maybe Double
_rtRotation = RenderTransform -> Maybe Double
_rtRotation RenderTransform
rt2 Maybe Double -> Maybe Double -> Maybe Double
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RenderTransform -> Maybe Double
_rtRotation RenderTransform
rt1,
    _rtGlobalAlpha :: Maybe Double
_rtGlobalAlpha = RenderTransform -> Maybe Double
_rtGlobalAlpha RenderTransform
rt2 Maybe Double -> Maybe Double -> Maybe Double
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RenderTransform -> Maybe Double
_rtGlobalAlpha RenderTransform
rt1,
    _rtScissor :: Maybe Rect
_rtScissor = RenderTransform -> Maybe Rect
_rtScissor RenderTransform
rt2 Maybe Rect -> Maybe Rect -> Maybe Rect
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> RenderTransform -> Maybe Rect
_rtScissor RenderTransform
rt1
  }

instance Monoid RenderTransform where
  mempty :: RenderTransform
mempty = RenderTransform
forall a. Default a => a
def

-- | Translate by the given offset.
animTranslation :: Point -> RenderTransform
animTranslation :: Point -> RenderTransform
animTranslation Point
p = RenderTransform
forall a. Default a => a
def { _rtTranslation = Just p }

-- | Scale by the given size.
animScale :: Point -> RenderTransform
animScale :: Point -> RenderTransform
animScale Point
p = RenderTransform
forall a. Default a => a
def { _rtScale = Just p }

-- | Rotate by the given angle.
animRotation :: Double -> RenderTransform
animRotation :: Double -> RenderTransform
animRotation Double
r = RenderTransform
forall a. Default a => a
def { _rtRotation = Just r }

-- | Apply the given alpha.
animGlobalAlpha :: Double -> RenderTransform
animGlobalAlpha :: Double -> RenderTransform
animGlobalAlpha Double
a = RenderTransform
forall a. Default a => a
def { _rtGlobalAlpha = Just a }

-- | Scissor to the given viewport.
animScissor :: Rect -> RenderTransform
animScissor :: Rect -> RenderTransform
animScissor Rect
vp = RenderTransform
forall a. Default a => a
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 :: forall e s.
WidgetEvent e =>
Transformer -> WidgetNode s e -> WidgetNode s e
animTransform Transformer
f WidgetNode s e
managed = [TransformCfg s e]
-> Transformer -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
[TransformCfg s e]
-> Transformer -> WidgetNode s e -> WidgetNode s e
animTransform_ [TransformCfg s e]
forall a. Default a => a
def Transformer
f WidgetNode s e
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_ :: forall e s.
WidgetEvent e =>
[TransformCfg s e]
-> Transformer -> WidgetNode s e -> WidgetNode s e
animTransform_ [TransformCfg s e]
configs Transformer
f WidgetNode s e
managed = WidgetNode s e
node where
  node :: WidgetNode s e
node = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
widgetType Widget s e
widget
    WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
Lens' (WidgetNode s e) WidgetNodeInfo
L.info ((WidgetNodeInfo -> Identity WidgetNodeInfo)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> ((Bool -> Identity Bool)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (Bool -> Identity Bool)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasFocusable s a => Lens' s a
Lens' WidgetNodeInfo Bool
L.focusable ((Bool -> Identity Bool)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Bool -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
    WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasChildren s a => Lens' s a
Lens' (WidgetNode s e) (Seq (WidgetNode s e))
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Seq (WidgetNode s e) -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ WidgetNode s e -> Seq (WidgetNode s e)
forall a. a -> Seq a
Seq.singleton WidgetNode s e
managed
  widgetType :: WidgetType
widgetType = Text -> WidgetType
WidgetType Text
"animTransform"
  widget :: Widget s e
widget = Transformer -> TransformCfg s e -> TransformState -> Widget s e
forall e s.
WidgetEvent e =>
Transformer -> TransformCfg s e -> TransformState -> Widget s e
makeTransform Transformer
f TransformCfg s e
config TransformState
forall a. Default a => a
def
  config :: TransformCfg s e
config = [TransformCfg s e] -> TransformCfg s e
forall a. Monoid a => [a] -> a
mconcat [TransformCfg s e]
configs

makeTransform
  :: WidgetEvent e
  => Transformer
  -> TransformCfg s e
  -> TransformState
  -> Widget s e
makeTransform :: forall e s.
WidgetEvent e =>
Transformer -> TransformCfg s e -> TransformState -> Widget s e
makeTransform Transformer
f TransformCfg s e
config TransformState
state = Widget s e
widget where
  baseWidget :: Widget s e
baseWidget = TransformState -> Container s e TransformState -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer TransformState
state Container s e TransformState
forall a. Default a => a
def {
    containerInit = init,
    containerMerge = merge,
    containerHandleMessage = handleMessage
  }
  widget :: Widget s e
widget = Widget s e
baseWidget {
    widgetRender = render
  }

  TransformCfg{[WidgetRequest s e]
Maybe Bool
Maybe Millisecond
_tfcAutoStart :: forall s e. TransformCfg s e -> Maybe Bool
_tfcDuration :: forall s e. TransformCfg s e -> Maybe Millisecond
_tfcOnFinishedReq :: forall s e. TransformCfg s e -> [WidgetRequest s e]
_tfcAutoStart :: Maybe Bool
_tfcDuration :: Maybe Millisecond
_tfcOnFinishedReq :: [WidgetRequest s e]
..} = TransformCfg s e
config
  TransformState{Bool
Millisecond
_tfsRunning :: TransformState -> Bool
_tfsStartTs :: TransformState -> Millisecond
_tfsRunning :: Bool
_tfsStartTs :: Millisecond
..} = TransformState
state
  autoStart :: Bool
autoStart = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
_tfcAutoStart
  duration :: Millisecond
duration = Millisecond -> Maybe Millisecond -> Millisecond
forall a. a -> Maybe a -> a
fromMaybe Millisecond
500 Maybe Millisecond
_tfcDuration
  period :: Millisecond
period = Millisecond
20
  steps :: Int
steps = Millisecond -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Millisecond -> Int) -> Millisecond -> Int
forall a b. (a -> b) -> a -> b
$ Millisecond
duration Millisecond -> Millisecond -> Millisecond
forall a. Integral a => a -> a -> a
`div` Millisecond
period

  finishedReq :: WidgetNode s e -> Millisecond -> WidgetRequest s e
finishedReq WidgetNode s e
node Millisecond
ts = WidgetNode s e -> AnimationMsg -> Millisecond -> WidgetRequest s e
forall i s e.
Typeable i =>
WidgetNode s e -> i -> Millisecond -> WidgetRequest s e
delayedMessage WidgetNode s e
node (Millisecond -> AnimationMsg
AnimationFinished Millisecond
ts) Millisecond
duration
  renderReq :: p -> p -> WidgetRequest s e
renderReq p
wenv p
node = WidgetRequest s e
forall {s} {e}. WidgetRequest s e
req where
    widgetId :: WidgetId
widgetId = p
node p -> Getting WidgetId p WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (a -> Const WidgetId a) -> p -> Const WidgetId p
forall s a. HasInfo s a => Lens' s a
Lens' p a
L.info ((a -> Const WidgetId a) -> p -> Const WidgetId p)
-> ((WidgetId -> Const WidgetId WidgetId) -> a -> Const WidgetId a)
-> Getting WidgetId p WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId) -> a -> Const WidgetId a
forall s a. HasWidgetId s a => Lens' s a
Lens' a WidgetId
L.widgetId
    req :: WidgetRequest s e
req = WidgetId -> Millisecond -> Maybe Int -> WidgetRequest s e
forall s e.
WidgetId -> Millisecond -> Maybe Int -> WidgetRequest s e
RenderEvery WidgetId
widgetId Millisecond
period (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
steps)

  init :: p -> WidgetNode s e -> WidgetResult s e
init p
wenv WidgetNode s e
node = WidgetResult s e
result where
    ts :: Millisecond
ts = p
wenv p -> Getting Millisecond p Millisecond -> Millisecond
forall s a. s -> Getting a s a -> a
^. Getting Millisecond p Millisecond
forall s a. HasTimestamp s a => Lens' s a
Lens' p Millisecond
L.timestamp
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Transformer -> TransformCfg s e -> TransformState -> Widget s e
forall e s.
WidgetEvent e =>
Transformer -> TransformCfg s e -> TransformState -> Widget s e
makeTransform Transformer
f TransformCfg s e
config (Bool -> Millisecond -> TransformState
TransformState Bool
True Millisecond
ts)
    result :: WidgetResult s e
result
      | Bool
autoStart = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetNode s e -> Millisecond -> WidgetRequest s e
forall {s} {e}. WidgetNode s e -> Millisecond -> WidgetRequest s e
finishedReq WidgetNode s e
node Millisecond
ts, p -> WidgetNode s e -> WidgetRequest s e
forall {p} {a} {p} {s} {e}.
(HasInfo p a, HasWidgetId a WidgetId) =>
p -> p -> WidgetRequest s e
renderReq p
wenv WidgetNode s e
node]
      | Bool
otherwise = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node

  merge :: p -> WidgetNode s e -> p -> TransformState -> WidgetResult s e
merge p
wenv WidgetNode s e
node p
oldNode TransformState
oldState = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Transformer -> TransformCfg s e -> TransformState -> Widget s e
forall e s.
WidgetEvent e =>
Transformer -> TransformCfg s e -> TransformState -> Widget s e
makeTransform Transformer
f TransformCfg s e
config TransformState
oldState

  handleMessage :: p -> WidgetNode s e -> p -> p -> Maybe (WidgetResult s e)
handleMessage p
wenv WidgetNode s e
node p
target p
message = Maybe (WidgetResult s e)
result where
    result :: Maybe (WidgetResult s e)
result = p -> Maybe AnimationMsg
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast p
message Maybe AnimationMsg
-> (AnimationMsg -> Maybe (WidgetResult s e))
-> Maybe (WidgetResult s e)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just (WidgetResult s e -> Maybe (WidgetResult s e))
-> (AnimationMsg -> WidgetResult s e)
-> AnimationMsg
-> Maybe (WidgetResult s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> WidgetNode s e -> AnimationMsg -> WidgetResult s e
forall {p}.
HasTimestamp p Millisecond =>
p -> WidgetNode s e -> AnimationMsg -> WidgetResult s e
handleAnimateMsg p
wenv WidgetNode s e
node

  handleAnimateMsg :: p -> WidgetNode s e -> AnimationMsg -> WidgetResult s e
handleAnimateMsg p
wenv WidgetNode s e
node AnimationMsg
msg = WidgetResult s e
result where
    widgetId :: WidgetId
widgetId = WidgetNode s e
node WidgetNode s e
-> Getting WidgetId (WidgetNode s e) WidgetId -> WidgetId
forall s a. s -> Getting a s a -> a
^. (WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> WidgetNode s e -> Const WidgetId (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
Lens' (WidgetNode s e) WidgetNodeInfo
L.info ((WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
 -> WidgetNode s e -> Const WidgetId (WidgetNode s e))
-> ((WidgetId -> Const WidgetId WidgetId)
    -> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo)
-> Getting WidgetId (WidgetNode s e) WidgetId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetId -> Const WidgetId WidgetId)
-> WidgetNodeInfo -> Const WidgetId WidgetNodeInfo
forall s a. HasWidgetId s a => Lens' s a
Lens' WidgetNodeInfo WidgetId
L.widgetId
    ts :: Millisecond
ts = p
wenv p -> Getting Millisecond p Millisecond -> Millisecond
forall s a. s -> Getting a s a -> a
^. Getting Millisecond p Millisecond
forall s a. HasTimestamp s a => Lens' s a
Lens' p Millisecond
L.timestamp
    startState :: TransformState
startState = Bool -> Millisecond -> TransformState
TransformState Bool
True Millisecond
ts
    startReqs :: [WidgetRequest s e]
startReqs = [WidgetNode s e -> Millisecond -> WidgetRequest s e
forall {s} {e}. WidgetNode s e -> Millisecond -> WidgetRequest s e
finishedReq WidgetNode s e
node Millisecond
ts, p -> WidgetNode s e -> WidgetRequest s e
forall {p} {a} {p} {s} {e}.
(HasInfo p a, HasWidgetId a WidgetId) =>
p -> p -> WidgetRequest s e
renderReq p
wenv WidgetNode s e
node]

    newNode :: TransformState -> WidgetNode s e
newNode TransformState
newState = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Transformer -> TransformCfg s e -> TransformState -> Widget s e
forall e s.
WidgetEvent e =>
Transformer -> TransformCfg s e -> TransformState -> Widget s e
makeTransform Transformer
f TransformCfg s e
config TransformState
newState
    result :: WidgetResult s e
result = case AnimationMsg
msg of
      AnimationMsg
AnimationStart -> WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs (TransformState -> WidgetNode s e
newNode TransformState
startState) [WidgetRequest s e]
startReqs
      AnimationMsg
AnimationStop -> WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs (TransformState -> WidgetNode s e
newNode TransformState
forall a. Default a => a
def) [WidgetId -> WidgetRequest s e
forall s e. WidgetId -> WidgetRequest s e
RenderStop WidgetId
widgetId]
      AnimationFinished Millisecond
ts'
        | Bool
isRelevant -> WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
node [WidgetRequest s e]
_tfcOnFinishedReq
        | Bool
otherwise -> WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node
        where isRelevant :: Bool
isRelevant = Bool
_tfsRunning Bool -> Bool -> Bool
&& Millisecond
ts' Millisecond -> Millisecond -> Bool
forall a. Eq a => a -> a -> Bool
== Millisecond
_tfsStartTs

  render :: WidgetEnv s e -> p -> Renderer -> IO ()
render WidgetEnv s e
wenv p
node Renderer
renderer = do
    if Bool
_tfsRunning
      then Renderer -> IO () -> IO ()
createOverlay Renderer
renderer (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Renderer -> IO ()
saveContext Renderer
renderer
        Renderer -> Point -> IO ()
setTranslation Renderer
renderer (Point -> IO ()) -> Point -> IO ()
forall a b. (a -> b) -> a -> b
$ WidgetEnv s e
wenv WidgetEnv s e -> Getting Point (WidgetEnv s e) Point -> Point
forall s a. s -> Getting a s a -> a
^. Getting Point (WidgetEnv s e) Point
forall s a. HasOffset s a => Lens' s a
Lens' (WidgetEnv s e) Point
L.offset
        Renderer -> Rect -> IO ()
intersectScissor Renderer
renderer Rect
scissorViewport
        Renderer -> Point -> IO ()
setTranslation Renderer
renderer (Point -> IO ()) -> Point -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
hDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
        Renderer -> Double -> IO ()
setRotation Renderer
renderer Double
rotation
        Renderer -> Point -> IO ()
setTranslation Renderer
renderer (Point -> IO ()) -> Point -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point (-Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) (-Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
hDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
        Renderer -> Point -> IO ()
setTranslation Renderer
renderer (Point -> IO ()) -> Point -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point (Double
txDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
sx)) (Double
tyDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
*(Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
sy))
        Renderer -> Point -> IO ()
setScale Renderer
renderer Point
scale
        Renderer -> Double -> IO ()
setGlobalAlpha Renderer
renderer Double
alpha
        Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
cnode WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget) WidgetEnv s e
wenv WidgetNode s e
cnode Renderer
renderer
        Renderer -> IO ()
restoreContext Renderer
renderer
      else Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
forall s e.
Widget s e -> WidgetEnv s e -> WidgetNode s e -> Renderer -> IO ()
widgetRender (WidgetNode s e
cnode WidgetNode s e
-> Getting (Widget s e) (WidgetNode s e) (Widget s e) -> Widget s e
forall s a. s -> Getting a s a -> a
^. Getting (Widget s e) (WidgetNode s e) (Widget s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget) WidgetEnv s e
wenv WidgetNode s e
cnode Renderer
renderer
    where
      vp :: Rect
vp@(Rect Double
x Double
y Double
w Double
h) = p
node p -> Getting Rect p Rect -> Rect
forall s a. s -> Getting a s a -> a
^. (a -> Const Rect a) -> p -> Const Rect p
forall s a. HasInfo s a => Lens' s a
Lens' p a
L.info ((a -> Const Rect a) -> p -> Const Rect p)
-> ((Rect -> Const Rect Rect) -> a -> Const Rect a)
-> Getting Rect p Rect
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rect -> Const Rect Rect) -> a -> Const Rect a
forall s a. HasViewport s a => Lens' s a
Lens' a Rect
L.viewport
      t :: Millisecond
t = Millisecond -> Millisecond -> Millisecond -> Millisecond
forall a. Ord a => a -> a -> a -> a
clamp Millisecond
0 Millisecond
duration (Millisecond -> Millisecond) -> Millisecond -> Millisecond
forall a b. (a -> b) -> a -> b
$ (WidgetEnv s e
wenv WidgetEnv s e
-> Getting Millisecond (WidgetEnv s e) Millisecond -> Millisecond
forall s a. s -> Getting a s a -> a
^. Getting Millisecond (WidgetEnv s e) Millisecond
forall s a. HasTimestamp s a => Lens' s a
Lens' (WidgetEnv s e) Millisecond
L.timestamp) Millisecond -> Millisecond -> Millisecond
forall a. Num a => a -> a -> a
- Millisecond
_tfsStartTs
      RenderTransform{Maybe Double
Maybe Rect
Maybe Point
_rtTranslation :: RenderTransform -> Maybe Point
_rtScale :: RenderTransform -> Maybe Point
_rtRotation :: RenderTransform -> Maybe Double
_rtGlobalAlpha :: RenderTransform -> Maybe Double
_rtScissor :: RenderTransform -> Maybe Rect
_rtTranslation :: Maybe Point
_rtScale :: Maybe Point
_rtRotation :: Maybe Double
_rtGlobalAlpha :: Maybe Double
_rtScissor :: Maybe Rect
..} = [RenderTransform] -> RenderTransform
forall a. Monoid a => [a] -> a
mconcat ([RenderTransform] -> RenderTransform)
-> [RenderTransform] -> RenderTransform
forall a b. (a -> b) -> a -> b
$ Transformer
f (Millisecond -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
t) Rect
vp
      Point Double
tx Double
ty = Point -> Maybe Point -> Point
forall a. a -> Maybe a -> a
fromMaybe (Double -> Double -> Point
Point Double
0 Double
0) Maybe Point
_rtTranslation
      scale :: Point
scale@(Point Double
sx Double
sy) = Point -> Maybe Point -> Point
forall a. a -> Maybe a -> a
fromMaybe (Double -> Double -> Point
Point Double
1 Double
1) Maybe Point
_rtScale
      rotation :: Double
rotation = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0 Maybe Double
_rtRotation
      alpha :: Double
alpha = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
1 Maybe Double
_rtGlobalAlpha
      scissorViewport :: Rect
scissorViewport = Rect -> Maybe Rect -> Rect
forall a. a -> Maybe a -> a
fromMaybe Rect
vp Maybe Rect
_rtScissor
      cnode :: WidgetNode s e
cnode = Seq (WidgetNode s e) -> Int -> WidgetNode s e
forall a. Seq a -> Int -> a
Seq.index (p
node p
-> Getting (Seq (WidgetNode s e)) p (Seq (WidgetNode s e))
-> Seq (WidgetNode s e)
forall s a. s -> Getting a s a -> a
^. Getting (Seq (WidgetNode s e)) p (Seq (WidgetNode s e))
forall s a. HasChildren s a => Lens' s a
Lens' p (Seq (WidgetNode s e))
L.children) Int
0