Shake.hs

{-|
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 (Eq, 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 {
  _shcDirection :: Maybe ShakeDirection,
  _shcAmplitude :: Maybe Double,
  _shcFrequency :: Maybe Int,
  _shcTransformCfg :: TransformCfg s e
} deriving (Eq, Show)

instance Default (ShakeCfg s e) where
  def = ShakeCfg {
    _shcDirection = Nothing,
    _shcAmplitude = Nothing,
    _shcFrequency = Nothing,
    _shcTransformCfg = def
  }

instance Semigroup (ShakeCfg s e) where
  (<>) sc1 sc2 = ShakeCfg {
    _shcDirection = _shcDirection sc2 <|> _shcDirection sc1,
    _shcAmplitude = _shcAmplitude sc2 <|> _shcAmplitude sc1,
    _shcFrequency = _shcFrequency sc2 <|> _shcFrequency sc1,
    _shcTransformCfg = _shcTransformCfg sc1 <> _shcTransformCfg sc2
  }

instance Monoid (ShakeCfg s e) where
  mempty = def

instance CmbAutoStart (ShakeCfg s e) where
  autoStart_ start = def {
    _shcTransformCfg = autoStart_ start
  }

instance CmbDuration (ShakeCfg s e) Millisecond where
  duration dur = def {
    _shcTransformCfg = duration dur
  }

instance WidgetEvent e => CmbOnFinished (ShakeCfg s e) e where
  onFinished handler = def {
    _shcTransformCfg = onFinished handler
  }

instance CmbOnFinishedReq (ShakeCfg s e) s e where
  onFinishedReq req = def {
    _shcTransformCfg = onFinishedReq req
  }

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

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

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

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

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

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

-- | Shakes a widget.
animShake
  :: WidgetEvent e
  => WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animShake managed = animShake_ def 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_ configs managed = node where
  node = animTransform_ [_shcTransformCfg] f managed
    & L.info . L.widgetType .~ "animShake"
  f t vp@(Rect _ _ w h) = (noScissor vp) <> case dir of
    ShakeH -> [animTranslation $ Point ((step t)*w) 0]
    ShakeV -> [animTranslation $ Point 0 ((step t)*h)]
    ShakeR -> [animRotation $ (step t)*180]
    ShakeS ->
      [ animTranslation $ Point ((1-(ss t))*w/2) ((1-(ss t))*h/2)
      , animScale $ Point (ss t) (ss t)
      ]
  noScissor (Rect x y w h) =
    [animScissor $ Rect (x-w*10) (y-h*10) (w*20) (h*20)]
  step t = (sin $ (fs t)*freq*2*pi)*amp
  ss t = 1-(amp/2)+(cos $ (fs t)*freq*2*pi)*amp/2
  fs t = clamp 0 1 $ t/(fromIntegral dur)
  dir = fromMaybe ShakeH _shcDirection
  amp = fromMaybe 0.1 _shcAmplitude
  freq = fromIntegral $ fromMaybe 2 _shcFrequency
  dur = fromMaybe 500 _tfcDuration
  TransformCfg{..} = _shcTransformCfg
  ShakeCfg{..} = mconcat configs