{-|
Module      : Monomer.Widgets.Animation.Zoom
Copyright   : (c) 2023 Ruslan Gadeev, Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Zoom animation widget. Wraps a child widget whose content will be animated.

Messages:

- Accepts a 'AnimationMsg', used to control the state of the animation.
-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}

module Monomer.Widgets.Animation.Zoom (
  -- * Configuration
  ZoomCfg,
  -- * Constructors
  animZoomIn,
  animZoomIn_,
  animZoomOut,
  animZoomOut_
) where

import Control.Lens ((&), (.~))
import Data.Default
import Data.Maybe

import Monomer.Helper
import Monomer.Widgets.Container
import Monomer.Widgets.Animation.Transform

import qualified Monomer.Lens as L

{-|
Configuration options for zoom:

- '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.
-}
newtype ZoomCfg s e = ZoomCfg {
  forall s e. ZoomCfg s e -> TransformCfg s e
_zmcTransformCfg :: TransformCfg s e
} deriving (ZoomCfg s e -> ZoomCfg s e -> Bool
(ZoomCfg s e -> ZoomCfg s e -> Bool)
-> (ZoomCfg s e -> ZoomCfg s e -> Bool) -> Eq (ZoomCfg s e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s e. Eq e => ZoomCfg s e -> ZoomCfg s e -> Bool
$c== :: forall s e. Eq e => ZoomCfg s e -> ZoomCfg s e -> Bool
== :: ZoomCfg s e -> ZoomCfg s e -> Bool
$c/= :: forall s e. Eq e => ZoomCfg s e -> ZoomCfg s e -> Bool
/= :: ZoomCfg s e -> ZoomCfg s e -> Bool
Eq, Int -> ZoomCfg s e -> ShowS
[ZoomCfg s e] -> ShowS
ZoomCfg s e -> String
(Int -> ZoomCfg s e -> ShowS)
-> (ZoomCfg s e -> String)
-> ([ZoomCfg s e] -> ShowS)
-> Show (ZoomCfg s e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s e. Int -> ZoomCfg s e -> ShowS
forall s e. [ZoomCfg s e] -> ShowS
forall s e. ZoomCfg s e -> String
$cshowsPrec :: forall s e. Int -> ZoomCfg s e -> ShowS
showsPrec :: Int -> ZoomCfg s e -> ShowS
$cshow :: forall s e. ZoomCfg s e -> String
show :: ZoomCfg s e -> String
$cshowList :: forall s e. [ZoomCfg s e] -> ShowS
showList :: [ZoomCfg s e] -> ShowS
Show)

instance Default (ZoomCfg s e) where
  def :: ZoomCfg s e
def = ZoomCfg {
    _zmcTransformCfg :: TransformCfg s e
_zmcTransformCfg = TransformCfg s e
forall a. Default a => a
def
  }

instance Semigroup (ZoomCfg s e) where
  <> :: ZoomCfg s e -> ZoomCfg s e -> ZoomCfg s e
(<>) ZoomCfg s e
zc1 ZoomCfg s e
zc2 = ZoomCfg {
    _zmcTransformCfg :: TransformCfg s e
_zmcTransformCfg = ZoomCfg s e -> TransformCfg s e
forall s e. ZoomCfg s e -> TransformCfg s e
_zmcTransformCfg ZoomCfg s e
zc1 TransformCfg s e -> TransformCfg s e -> TransformCfg s e
forall a. Semigroup a => a -> a -> a
<> ZoomCfg s e -> TransformCfg s e
forall s e. ZoomCfg s e -> TransformCfg s e
_zmcTransformCfg ZoomCfg s e
zc2
  }

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

instance CmbAutoStart (ZoomCfg s e) where
  autoStart_ :: Bool -> ZoomCfg s e
autoStart_ Bool
start = ZoomCfg Any Any
forall a. Default a => a
def {
    _zmcTransformCfg = autoStart_ start
  }

instance CmbDuration (ZoomCfg s e) Millisecond where
  duration :: Millisecond -> ZoomCfg s e
duration Millisecond
dur = ZoomCfg Any Any
forall a. Default a => a
def {
    _zmcTransformCfg = duration dur
  }

instance WidgetEvent e => CmbOnFinished (ZoomCfg s e) e where
  onFinished :: e -> ZoomCfg s e
onFinished e
handler = ZoomCfg Any Any
forall a. Default a => a
def {
    _zmcTransformCfg = onFinished handler
  }

instance CmbOnFinishedReq (ZoomCfg s e) s e where
  onFinishedReq :: WidgetRequest s e -> ZoomCfg s e
onFinishedReq WidgetRequest s e
req = ZoomCfg Any Any
forall a. Default a => a
def {
    _zmcTransformCfg = onFinishedReq req
  }

-- | Animates a widget to fully visible by increasing scale.
animZoomIn
  :: WidgetEvent e
  => WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animZoomIn :: forall e s. WidgetEvent e => WidgetNode s e -> WidgetNode s e
animZoomIn WidgetNode s e
managed = [ZoomCfg s e] -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
[ZoomCfg s e] -> WidgetNode s e -> WidgetNode s e
animZoomIn_ [ZoomCfg s e]
forall a. Default a => a
def WidgetNode s e
managed

-- | Animates a widget to fully visible by increasing scale. Accepts config.
animZoomIn_
  :: WidgetEvent e
  => [ZoomCfg s e]     -- ^ The config options.
  -> WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animZoomIn_ :: forall e s.
WidgetEvent e =>
[ZoomCfg s e] -> WidgetNode s e -> WidgetNode s e
animZoomIn_ [ZoomCfg s e]
configs WidgetNode s e
managed = [ZoomCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
forall e s.
WidgetEvent e =>
[ZoomCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
makeNode [ZoomCfg s e]
configs WidgetNode s e
managed Bool
True
  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))
-> ((WidgetType -> Identity WidgetType)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (WidgetType -> Identity WidgetType)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetType -> Identity WidgetType)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasWidgetType s a => Lens' s a
Lens' WidgetNodeInfo WidgetType
L.widgetType ((WidgetType -> Identity WidgetType)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> WidgetType -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ WidgetType
"animZoomIn"

-- | Animates a widget to not visible by decreasing scale.
animZoomOut
  :: WidgetEvent e
  => WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animZoomOut :: forall e s. WidgetEvent e => WidgetNode s e -> WidgetNode s e
animZoomOut WidgetNode s e
managed = [ZoomCfg s e] -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
[ZoomCfg s e] -> WidgetNode s e -> WidgetNode s e
animZoomOut_ [ZoomCfg s e]
forall a. Default a => a
def WidgetNode s e
managed

-- | Animates a widget to not visible by decreasing scale. Accepts config.
animZoomOut_
  :: WidgetEvent e
  => [ZoomCfg s e]     -- ^ The config options.
  -> WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animZoomOut_ :: forall e s.
WidgetEvent e =>
[ZoomCfg s e] -> WidgetNode s e -> WidgetNode s e
animZoomOut_ [ZoomCfg s e]
configs WidgetNode s e
managed = [ZoomCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
forall e s.
WidgetEvent e =>
[ZoomCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
makeNode [ZoomCfg s e]
configs WidgetNode s e
managed Bool
False
  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))
-> ((WidgetType -> Identity WidgetType)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (WidgetType -> Identity WidgetType)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WidgetType -> Identity WidgetType)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasWidgetType s a => Lens' s a
Lens' WidgetNodeInfo WidgetType
L.widgetType ((WidgetType -> Identity WidgetType)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> WidgetType -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ WidgetType
"animZoomOut"

makeNode
  :: WidgetEvent e
  => [ZoomCfg s e]
  -> WidgetNode s e
  -> Bool
  -> WidgetNode s e
makeNode :: forall e s.
WidgetEvent e =>
[ZoomCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
makeNode [ZoomCfg s e]
configs WidgetNode s e
managed Bool
isZoomIn = WidgetNode s e
node where
  node :: WidgetNode s e
node = [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
_zmcTransformCfg] Transformer
f WidgetNode s e
managed
  f :: Transformer
f Double
t (Rect Double
_ Double
_ Double
w Double
h) =
    [ Point -> RenderTransform
animTranslation (Point -> RenderTransform) -> Point -> RenderTransform
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point (Double -> Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a -> a
ft Double
t Double
w) (Double -> Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a -> a
ft Double
t Double
h)
    , Point -> RenderTransform
animScale (Point -> RenderTransform) -> Point -> RenderTransform
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point (Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a
fs Double
t) (Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a
fs Double
t)
    ]
  ft :: a -> a -> a
ft a
t a
s = (a
1a -> a -> a
forall a. Num a => a -> a -> a
-(a -> a
forall {a}. (Ord a, Fractional a) => a -> a
fs a
t))a -> a -> a
forall a. Num a => a -> a -> a
*a
sa -> a -> a
forall a. Fractional a => a -> a -> a
/a
2
  fs :: a -> a
fs a
t = if Bool
isZoomIn
    then a -> a
forall {a}. (Ord a, Fractional a) => a -> a
fwdStep a
t
    else a
1a -> a -> a
forall a. Num a => a -> a -> a
-(a -> a
forall {a}. (Ord a, Fractional a) => a -> a
fwdStep a
t)
  fwdStep :: a -> a
fwdStep a
t = a -> a -> a -> a
forall a. Ord a => a -> a -> a -> a
clamp a
0 a
1 (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
ta -> a -> a
forall a. Fractional a => a -> a -> a
/(Millisecond -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
dur)
  dur :: Millisecond
dur = Millisecond -> Maybe Millisecond -> Millisecond
forall a. a -> Maybe a -> a
fromMaybe Millisecond
500 Maybe Millisecond
_tfcDuration
  TransformCfg{[WidgetRequest s e]
Maybe Bool
Maybe Millisecond
_tfcDuration :: Maybe Millisecond
_tfcAutoStart :: Maybe Bool
_tfcOnFinishedReq :: [WidgetRequest s e]
_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]
..} = TransformCfg s e
_zmcTransformCfg
  ZoomCfg{TransformCfg s e
_zmcTransformCfg :: forall s e. ZoomCfg s e -> TransformCfg s e
_zmcTransformCfg :: TransformCfg s e
..} = [ZoomCfg s e] -> ZoomCfg s e
forall a. Monoid a => [a] -> a
mconcat [ZoomCfg s e]
configs