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

Shake 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.Shake (
  -- * Configuration
  ShakeCfg,
  shakeH,
  shakeV,
  shakeR,
  shakeS,
  shakeAmplitude,
  shakeFrequency,
  -- * Constructors
  animShake,
  animShake_
) where

import Control.Applicative ((<|>))
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

data ShakeDirection
  = ShakeH
  | ShakeV
  | ShakeR
  | ShakeS
  deriving (ShakeDirection -> ShakeDirection -> Bool
(ShakeDirection -> ShakeDirection -> Bool)
-> (ShakeDirection -> ShakeDirection -> Bool) -> Eq ShakeDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShakeDirection -> ShakeDirection -> Bool
== :: ShakeDirection -> ShakeDirection -> Bool
$c/= :: ShakeDirection -> ShakeDirection -> Bool
/= :: ShakeDirection -> ShakeDirection -> Bool
Eq, Int -> ShakeDirection -> ShowS
[ShakeDirection] -> ShowS
ShakeDirection -> String
(Int -> ShakeDirection -> ShowS)
-> (ShakeDirection -> String)
-> ([ShakeDirection] -> ShowS)
-> Show ShakeDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ShakeDirection -> ShowS
showsPrec :: Int -> ShakeDirection -> ShowS
$cshow :: ShakeDirection -> String
show :: ShakeDirection -> String
$cshowList :: [ShakeDirection] -> ShowS
showList :: [ShakeDirection] -> ShowS
Show)

{-|
Configuration options for shake:

- '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.
- 'shakeAmplitude': amplitude of the animation. Defaults to 0.1.
- 'shakeFrequency': frequency of the animation. Defaults to 2.
- Individual combinators for direction.
-}
data ShakeCfg s e = ShakeCfg {
  forall s e. ShakeCfg s e -> Maybe ShakeDirection
_shcDirection :: Maybe ShakeDirection,
  forall s e. ShakeCfg s e -> Maybe Double
_shcAmplitude :: Maybe Double,
  forall s e. ShakeCfg s e -> Maybe Int
_shcFrequency :: Maybe Int,
  forall s e. ShakeCfg s e -> TransformCfg s e
_shcTransformCfg :: TransformCfg s e
} deriving (ShakeCfg s e -> ShakeCfg s e -> Bool
(ShakeCfg s e -> ShakeCfg s e -> Bool)
-> (ShakeCfg s e -> ShakeCfg s e -> Bool) -> Eq (ShakeCfg s e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s e. Eq e => ShakeCfg s e -> ShakeCfg s e -> Bool
$c== :: forall s e. Eq e => ShakeCfg s e -> ShakeCfg s e -> Bool
== :: ShakeCfg s e -> ShakeCfg s e -> Bool
$c/= :: forall s e. Eq e => ShakeCfg s e -> ShakeCfg s e -> Bool
/= :: ShakeCfg s e -> ShakeCfg s e -> Bool
Eq, Int -> ShakeCfg s e -> ShowS
[ShakeCfg s e] -> ShowS
ShakeCfg s e -> String
(Int -> ShakeCfg s e -> ShowS)
-> (ShakeCfg s e -> String)
-> ([ShakeCfg s e] -> ShowS)
-> Show (ShakeCfg s e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s e. Int -> ShakeCfg s e -> ShowS
forall s e. [ShakeCfg s e] -> ShowS
forall s e. ShakeCfg s e -> String
$cshowsPrec :: forall s e. Int -> ShakeCfg s e -> ShowS
showsPrec :: Int -> ShakeCfg s e -> ShowS
$cshow :: forall s e. ShakeCfg s e -> String
show :: ShakeCfg s e -> String
$cshowList :: forall s e. [ShakeCfg s e] -> ShowS
showList :: [ShakeCfg s e] -> ShowS
Show)

instance Default (ShakeCfg s e) where
  def :: ShakeCfg s e
def = ShakeCfg {
    _shcDirection :: Maybe ShakeDirection
_shcDirection = Maybe ShakeDirection
forall a. Maybe a
Nothing,
    _shcAmplitude :: Maybe Double
_shcAmplitude = Maybe Double
forall a. Maybe a
Nothing,
    _shcFrequency :: Maybe Int
_shcFrequency = Maybe Int
forall a. Maybe a
Nothing,
    _shcTransformCfg :: TransformCfg s e
_shcTransformCfg = TransformCfg s e
forall a. Default a => a
def
  }

instance Semigroup (ShakeCfg s e) where
  <> :: ShakeCfg s e -> ShakeCfg s e -> ShakeCfg s e
(<>) ShakeCfg s e
sc1 ShakeCfg s e
sc2 = ShakeCfg {
    _shcDirection :: Maybe ShakeDirection
_shcDirection = ShakeCfg s e -> Maybe ShakeDirection
forall s e. ShakeCfg s e -> Maybe ShakeDirection
_shcDirection ShakeCfg s e
sc2 Maybe ShakeDirection
-> Maybe ShakeDirection -> Maybe ShakeDirection
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ShakeCfg s e -> Maybe ShakeDirection
forall s e. ShakeCfg s e -> Maybe ShakeDirection
_shcDirection ShakeCfg s e
sc1,
    _shcAmplitude :: Maybe Double
_shcAmplitude = ShakeCfg s e -> Maybe Double
forall s e. ShakeCfg s e -> Maybe Double
_shcAmplitude ShakeCfg s e
sc2 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
<|> ShakeCfg s e -> Maybe Double
forall s e. ShakeCfg s e -> Maybe Double
_shcAmplitude ShakeCfg s e
sc1,
    _shcFrequency :: Maybe Int
_shcFrequency = ShakeCfg s e -> Maybe Int
forall s e. ShakeCfg s e -> Maybe Int
_shcFrequency ShakeCfg s e
sc2 Maybe Int -> Maybe Int -> Maybe Int
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ShakeCfg s e -> Maybe Int
forall s e. ShakeCfg s e -> Maybe Int
_shcFrequency ShakeCfg s e
sc1,
    _shcTransformCfg :: TransformCfg s e
_shcTransformCfg = ShakeCfg s e -> TransformCfg s e
forall s e. ShakeCfg s e -> TransformCfg s e
_shcTransformCfg ShakeCfg s e
sc1 TransformCfg s e -> TransformCfg s e -> TransformCfg s e
forall a. Semigroup a => a -> a -> a
<> ShakeCfg s e -> TransformCfg s e
forall s e. ShakeCfg s e -> TransformCfg s e
_shcTransformCfg ShakeCfg s e
sc2
  }

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

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

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

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

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

-- | Shake horizontally.
shakeH :: ShakeCfg s e
shakeH :: forall s e. ShakeCfg s e
shakeH = ShakeCfg s e
forall a. Default a => a
def { _shcDirection = Just ShakeH }

-- | Shake vertically.
shakeV :: ShakeCfg s e
shakeV :: forall s e. ShakeCfg s e
shakeV = ShakeCfg s e
forall a. Default a => a
def { _shcDirection = Just ShakeV }

-- | Shake by rotating.
shakeR :: ShakeCfg s e
shakeR :: forall s e. ShakeCfg s e
shakeR = ShakeCfg s e
forall a. Default a => a
def { _shcDirection = Just ShakeR }

-- | Shake by scaling.
shakeS :: ShakeCfg s e
shakeS :: forall s e. ShakeCfg s e
shakeS = ShakeCfg s e
forall a. Default a => a
def { _shcDirection = Just ShakeS }

-- | Amplitude of the animation. Defaults to 1.
shakeAmplitude :: Double -> ShakeCfg s e
shakeAmplitude :: forall s e. Double -> ShakeCfg s e
shakeAmplitude Double
amp = ShakeCfg s e
forall a. Default a => a
def { _shcAmplitude = Just amp }

-- | Frequency of the animation. Defaults to 2.
shakeFrequency :: Int -> ShakeCfg s e
shakeFrequency :: forall s e. Int -> ShakeCfg s e
shakeFrequency Int
freq = ShakeCfg s e
forall a. Default a => a
def { _shcFrequency = Just freq }

-- | Shakes a widget.
animShake
  :: WidgetEvent e
  => WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animShake :: forall e s. WidgetEvent e => WidgetNode s e -> WidgetNode s e
animShake WidgetNode s e
managed = [ShakeCfg s e] -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
[ShakeCfg s e] -> WidgetNode s e -> WidgetNode s e
animShake_ [ShakeCfg s e]
forall a. Default a => a
def WidgetNode s e
managed

-- | Shakes a widget. Accepts config.
animShake_
  :: WidgetEvent e
  => [ShakeCfg s e]    -- ^ The config options.
  -> WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animShake_ :: forall e s.
WidgetEvent e =>
[ShakeCfg s e] -> WidgetNode s e -> WidgetNode s e
animShake_ [ShakeCfg s e]
configs WidgetNode s e
managed = 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
_shcTransformCfg] Transformer
f WidgetNode s e
managed
    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
"animShake"
  f :: Transformer
f Double
t vp :: Rect
vp@(Rect Double
_ Double
_ Double
w Double
h) = (Rect -> [RenderTransform]
noScissor Rect
vp) [RenderTransform] -> [RenderTransform] -> [RenderTransform]
forall a. Semigroup a => a -> a -> a
<> case ShakeDirection
dir of
    ShakeDirection
ShakeH -> [Point -> RenderTransform
animTranslation (Point -> RenderTransform) -> Point -> RenderTransform
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point ((Double -> Double
step Double
t)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
w) Double
0]
    ShakeDirection
ShakeV -> [Point -> RenderTransform
animTranslation (Point -> RenderTransform) -> Point -> RenderTransform
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point Double
0 ((Double -> Double
step Double
t)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
h)]
    ShakeDirection
ShakeR -> [Double -> RenderTransform
animRotation (Double -> RenderTransform) -> Double -> RenderTransform
forall a b. (a -> b) -> a -> b
$ (Double -> Double
step Double
t)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
180]
    ShakeDirection
ShakeS ->
      [ Point -> RenderTransform
animTranslation (Point -> RenderTransform) -> Point -> RenderTransform
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point ((Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-(Double -> Double
ss Double
t))Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) ((Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-(Double -> Double
ss Double
t))Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
hDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)
      , Point -> RenderTransform
animScale (Point -> RenderTransform) -> Point -> RenderTransform
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point (Double -> Double
ss Double
t) (Double -> Double
ss Double
t)
      ]
  noScissor :: Rect -> [RenderTransform]
noScissor (Rect Double
x Double
y Double
w Double
h) =
    [Rect -> RenderTransform
animScissor (Rect -> RenderTransform) -> Rect -> RenderTransform
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double -> Double -> Rect
Rect (Double
xDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
wDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
10) (Double
yDouble -> Double -> Double
forall a. Num a => a -> a -> a
-Double
hDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
10) (Double
wDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
20) (Double
hDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
20)]
  step :: Double -> Double
step Double
t = (Double -> Double
forall a. Floating a => a -> a
sin (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ (Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a
fs Double
t)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
freqDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
pi)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
amp
  ss :: Double -> Double
ss Double
t = Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-(Double
ampDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2)Double -> Double -> Double
forall a. Num a => a -> a -> a
+(Double -> Double
forall a. Floating a => a -> a
cos (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ (Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a
fs Double
t)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
freqDouble -> Double -> Double
forall a. Num a => a -> a -> a
*Double
2Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
forall a. Floating a => a
pi)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
ampDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
  fs :: a -> a
fs 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)
  dir :: ShakeDirection
dir = ShakeDirection -> Maybe ShakeDirection -> ShakeDirection
forall a. a -> Maybe a -> a
fromMaybe ShakeDirection
ShakeH Maybe ShakeDirection
_shcDirection
  amp :: Double
amp = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
0.1 Maybe Double
_shcAmplitude
  freq :: Double
freq = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
2 Maybe Int
_shcFrequency
  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
_shcTransformCfg
  ShakeCfg{Maybe Double
Maybe Int
Maybe ShakeDirection
TransformCfg s e
_shcDirection :: forall s e. ShakeCfg s e -> Maybe ShakeDirection
_shcAmplitude :: forall s e. ShakeCfg s e -> Maybe Double
_shcFrequency :: forall s e. ShakeCfg s e -> Maybe Int
_shcTransformCfg :: forall s e. ShakeCfg s e -> TransformCfg s e
_shcTransformCfg :: TransformCfg s e
_shcDirection :: Maybe ShakeDirection
_shcAmplitude :: Maybe Double
_shcFrequency :: Maybe Int
..} = [ShakeCfg s e] -> ShakeCfg s e
forall a. Monoid a => [a] -> a
mconcat [ShakeCfg s e]
configs