Wipe.hs

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

Wipe 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.Wipe (
  -- * Configuration
  WipeCfg,
  wipeLeft,
  wipeRight,
  wipeTop,
  wipeBottom,
  wipeDoorH,
  wipeDoorV,
  wipeRect,
  -- * Constructors
  animWipeIn,
  animWipeIn_,
  animWipeOut,
  animWipeOut_
) 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 WipeDirection
  = WipeLeft
  | WipeRight
  | WipeTop
  | WipeBottom
  | WipeDoorH
  | WipeDoorV
  | WipeRect
  deriving (Eq, Show)

{-|
Configuration options for wipe:

- '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.
- Individual combinators for direction.
-}
data WipeCfg s e = WipeCfg {
  _wpcDirection :: Maybe WipeDirection,
  _wpcTransformCfg :: TransformCfg s e
} deriving (Eq, Show)

instance Default (WipeCfg s e) where
  def = WipeCfg {
    _wpcDirection = Nothing,
    _wpcTransformCfg = def
  }

instance Semigroup (WipeCfg s e) where
  (<>) wc1 wc2 = WipeCfg {
    _wpcDirection = _wpcDirection wc2 <|> _wpcDirection wc1,
    _wpcTransformCfg = _wpcTransformCfg wc1 <> _wpcTransformCfg wc2
  }

instance Monoid (WipeCfg s e) where
  mempty = def

instance CmbAutoStart (WipeCfg s e) where
  autoStart_ start = def {
    _wpcTransformCfg = autoStart_ start
  }

instance CmbDuration (WipeCfg s e) Millisecond where
  duration dur = def {
    _wpcTransformCfg = duration dur
  }

instance WidgetEvent e => CmbOnFinished (WipeCfg s e) e where
  onFinished handler = def {
    _wpcTransformCfg = onFinished handler
  }

instance CmbOnFinishedReq (WipeCfg s e) s e where
  onFinishedReq req = def {
    _wpcTransformCfg = onFinishedReq req
  }

-- | Wipe from/to left.
wipeLeft :: WipeCfg s e
wipeLeft = def { _wpcDirection = Just WipeLeft }

-- | Wipe from/to right.
wipeRight :: WipeCfg s e
wipeRight = def { _wpcDirection = Just WipeRight }

-- | Wipe from/to top.
wipeTop :: WipeCfg s e
wipeTop = def { _wpcDirection = Just WipeTop }

-- | Wipe from/to bottom.
wipeBottom :: WipeCfg s e
wipeBottom = def { _wpcDirection = Just WipeBottom }

-- | Wipe horizontally in a door shape.
wipeDoorH :: WipeCfg s e
wipeDoorH = def { _wpcDirection = Just WipeDoorH }

-- | Wipe vertically in a door shape.
wipeDoorV :: WipeCfg s e
wipeDoorV = def { _wpcDirection = Just WipeDoorV }

-- | Wipe in a rectangle shape.
wipeRect :: WipeCfg s e
wipeRect = def { _wpcDirection = Just WipeRect }

-- | Animates a widget from the left to fully visible.
animWipeIn
  :: WidgetEvent e
  => WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animWipeIn managed = animWipeIn_ def managed

-- | Animates a widget from the provided direction to fully visible (defaults
--   to left). Accepts config.
animWipeIn_
  :: WidgetEvent e
  => [WipeCfg s e]     -- ^ The config options.
  -> WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animWipeIn_ configs managed = makeNode configs managed True
  & L.info . L.widgetType .~ "animWipeIn"

-- | Animates a widget to the left from visible to not visible.
animWipeOut
  :: WidgetEvent e
  => WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animWipeOut managed = animWipeOut_ def managed

-- | Animates a widget to the provided direction from visible to not
--   visible (defaults to left). Accepts config.
animWipeOut_
  :: WidgetEvent e
  => [WipeCfg s e]     -- ^ The config options.
  -> WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created animation container.
animWipeOut_ configs managed = makeNode configs managed False
  & L.info . L.widgetType .~ "animWipeOut"

makeNode
  :: WidgetEvent e
  => [WipeCfg s e]
  -> WidgetNode s e
  -> Bool
  -> WidgetNode s e
makeNode configs managed isWipeIn = node where
  node = animTransform_ [_wpcTransformCfg] f managed
  f t (Rect x y w h) = [animScissor vp] where
    vp = case dir of
      WipeLeft -> Rect x y dw h
      WipeRight -> Rect (x+(1-(step t))*w) y dw h
      WipeTop -> Rect x y w dh
      WipeBottom -> Rect x (y+(1-(step t))*h) w dh
      WipeDoorH -> Rect dx y dw h
      WipeDoorV -> Rect x dy w dh
      WipeRect -> Rect dx dy dw dh
    (dx, dy) = (x+(1-(step t))*w/2, y+(1-(step t))*h/2)
    (dw, dh) = ((step t)*w, (step t)*h)
  step t = if isWipeIn
    then fwdStep t
    else 1-(fwdStep t)
  fwdStep t = clamp 0 1 $ t/(fromIntegral dur)
  dir = fromMaybe WipeLeft _wpcDirection
  dur = fromMaybe 500 _tfcDuration
  TransformCfg{..} = _wpcTransformCfg
  WipeCfg{..} = mconcat configs