{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}
module Monomer.Widgets.Animation.Slide (
SlideCfg,
slideLeft,
slideRight,
slideTop,
slideBottom,
animSlideIn,
animSlideIn_,
animSlideOut,
animSlideOut_
) 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 SlideDirection
= SlideLeft
| SlideRight
| SlideUp
| SlideDown
deriving (SlideDirection -> SlideDirection -> Bool
(SlideDirection -> SlideDirection -> Bool)
-> (SlideDirection -> SlideDirection -> Bool) -> Eq SlideDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SlideDirection -> SlideDirection -> Bool
== :: SlideDirection -> SlideDirection -> Bool
$c/= :: SlideDirection -> SlideDirection -> Bool
/= :: SlideDirection -> SlideDirection -> Bool
Eq, Int -> SlideDirection -> ShowS
[SlideDirection] -> ShowS
SlideDirection -> String
(Int -> SlideDirection -> ShowS)
-> (SlideDirection -> String)
-> ([SlideDirection] -> ShowS)
-> Show SlideDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SlideDirection -> ShowS
showsPrec :: Int -> SlideDirection -> ShowS
$cshow :: SlideDirection -> String
show :: SlideDirection -> String
$cshowList :: [SlideDirection] -> ShowS
showList :: [SlideDirection] -> ShowS
Show)
data SlideCfg s e = SlideCfg {
forall s e. SlideCfg s e -> Maybe SlideDirection
_slcDirection :: Maybe SlideDirection,
forall s e. SlideCfg s e -> TransformCfg s e
_slcTransformCfg :: TransformCfg s e
} deriving (SlideCfg s e -> SlideCfg s e -> Bool
(SlideCfg s e -> SlideCfg s e -> Bool)
-> (SlideCfg s e -> SlideCfg s e -> Bool) -> Eq (SlideCfg s e)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s e. Eq e => SlideCfg s e -> SlideCfg s e -> Bool
$c== :: forall s e. Eq e => SlideCfg s e -> SlideCfg s e -> Bool
== :: SlideCfg s e -> SlideCfg s e -> Bool
$c/= :: forall s e. Eq e => SlideCfg s e -> SlideCfg s e -> Bool
/= :: SlideCfg s e -> SlideCfg s e -> Bool
Eq, Int -> SlideCfg s e -> ShowS
[SlideCfg s e] -> ShowS
SlideCfg s e -> String
(Int -> SlideCfg s e -> ShowS)
-> (SlideCfg s e -> String)
-> ([SlideCfg s e] -> ShowS)
-> Show (SlideCfg s e)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s e. Int -> SlideCfg s e -> ShowS
forall s e. [SlideCfg s e] -> ShowS
forall s e. SlideCfg s e -> String
$cshowsPrec :: forall s e. Int -> SlideCfg s e -> ShowS
showsPrec :: Int -> SlideCfg s e -> ShowS
$cshow :: forall s e. SlideCfg s e -> String
show :: SlideCfg s e -> String
$cshowList :: forall s e. [SlideCfg s e] -> ShowS
showList :: [SlideCfg s e] -> ShowS
Show)
instance Default (SlideCfg s e) where
def :: SlideCfg s e
def = SlideCfg {
_slcDirection :: Maybe SlideDirection
_slcDirection = Maybe SlideDirection
forall a. Maybe a
Nothing,
_slcTransformCfg :: TransformCfg s e
_slcTransformCfg = TransformCfg s e
forall a. Default a => a
def
}
instance Semigroup (SlideCfg s e) where
<> :: SlideCfg s e -> SlideCfg s e -> SlideCfg s e
(<>) SlideCfg s e
fc1 SlideCfg s e
fc2 = SlideCfg {
_slcDirection :: Maybe SlideDirection
_slcDirection = SlideCfg s e -> Maybe SlideDirection
forall s e. SlideCfg s e -> Maybe SlideDirection
_slcDirection SlideCfg s e
fc2 Maybe SlideDirection
-> Maybe SlideDirection -> Maybe SlideDirection
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SlideCfg s e -> Maybe SlideDirection
forall s e. SlideCfg s e -> Maybe SlideDirection
_slcDirection SlideCfg s e
fc1,
_slcTransformCfg :: TransformCfg s e
_slcTransformCfg = SlideCfg s e -> TransformCfg s e
forall s e. SlideCfg s e -> TransformCfg s e
_slcTransformCfg SlideCfg s e
fc1 TransformCfg s e -> TransformCfg s e -> TransformCfg s e
forall a. Semigroup a => a -> a -> a
<> SlideCfg s e -> TransformCfg s e
forall s e. SlideCfg s e -> TransformCfg s e
_slcTransformCfg SlideCfg s e
fc2
}
instance Monoid (SlideCfg s e) where
mempty :: SlideCfg s e
mempty = SlideCfg s e
forall a. Default a => a
def
instance CmbAutoStart (SlideCfg s e) where
autoStart_ :: Bool -> SlideCfg s e
autoStart_ Bool
start = SlideCfg Any Any
forall a. Default a => a
def {
_slcTransformCfg = autoStart_ start
}
instance CmbDuration (SlideCfg s e) Millisecond where
duration :: Millisecond -> SlideCfg s e
duration Millisecond
dur = SlideCfg Any Any
forall a. Default a => a
def {
_slcTransformCfg = duration dur
}
instance WidgetEvent e => CmbOnFinished (SlideCfg s e) e where
onFinished :: e -> SlideCfg s e
onFinished e
handler = SlideCfg Any Any
forall a. Default a => a
def {
_slcTransformCfg = onFinished handler
}
instance CmbOnFinishedReq (SlideCfg s e) s e where
onFinishedReq :: WidgetRequest s e -> SlideCfg s e
onFinishedReq WidgetRequest s e
req = SlideCfg Any Any
forall a. Default a => a
def {
_slcTransformCfg = onFinishedReq req
}
slideLeft :: SlideCfg s e
slideLeft :: forall s e. SlideCfg s e
slideLeft = SlideCfg s e
forall a. Default a => a
def { _slcDirection = Just SlideLeft }
slideRight :: SlideCfg s e
slideRight :: forall s e. SlideCfg s e
slideRight = SlideCfg s e
forall a. Default a => a
def { _slcDirection = Just SlideRight }
slideTop :: SlideCfg s e
slideTop :: forall s e. SlideCfg s e
slideTop = SlideCfg s e
forall a. Default a => a
def { _slcDirection = Just SlideUp }
slideBottom :: SlideCfg s e
slideBottom :: forall s e. SlideCfg s e
slideBottom = SlideCfg s e
forall a. Default a => a
def { _slcDirection = Just SlideDown }
animSlideIn
:: WidgetEvent e
=> WidgetNode s e
-> WidgetNode s e
animSlideIn :: forall e s. WidgetEvent e => WidgetNode s e -> WidgetNode s e
animSlideIn WidgetNode s e
managed = [SlideCfg s e] -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
[SlideCfg s e] -> WidgetNode s e -> WidgetNode s e
animSlideIn_ [SlideCfg s e]
forall a. Default a => a
def WidgetNode s e
managed
animSlideIn_
:: WidgetEvent e
=> [SlideCfg s e]
-> WidgetNode s e
-> WidgetNode s e
animSlideIn_ :: forall e s.
WidgetEvent e =>
[SlideCfg s e] -> WidgetNode s e -> WidgetNode s e
animSlideIn_ [SlideCfg s e]
configs WidgetNode s e
managed = [SlideCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
forall e s.
WidgetEvent e =>
[SlideCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
makeNode [SlideCfg 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
"animSlideIn"
animSlideOut
:: WidgetEvent e
=> WidgetNode s e
-> WidgetNode s e
animSlideOut :: forall e s. WidgetEvent e => WidgetNode s e -> WidgetNode s e
animSlideOut WidgetNode s e
managed = [SlideCfg s e] -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
[SlideCfg s e] -> WidgetNode s e -> WidgetNode s e
animSlideOut_ [SlideCfg s e]
forall a. Default a => a
def WidgetNode s e
managed
animSlideOut_
:: WidgetEvent e
=> [SlideCfg s e]
-> WidgetNode s e
-> WidgetNode s e
animSlideOut_ :: forall e s.
WidgetEvent e =>
[SlideCfg s e] -> WidgetNode s e -> WidgetNode s e
animSlideOut_ [SlideCfg s e]
configs WidgetNode s e
managed = [SlideCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
forall e s.
WidgetEvent e =>
[SlideCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
makeNode [SlideCfg 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
"animSlideOut"
makeNode
:: WidgetEvent e
=> [SlideCfg s e]
-> WidgetNode s e
-> Bool
-> WidgetNode s e
makeNode :: forall e s.
WidgetEvent e =>
[SlideCfg s e] -> WidgetNode s e -> Bool -> WidgetNode s e
makeNode [SlideCfg s e]
configs WidgetNode s e
managed Bool
isSlideIn = 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
_slcTransformCfg] Transformer
f WidgetNode s e
managed
f :: Transformer
f Double
t Rect
vp = [Point -> RenderTransform
animTranslation (Point -> RenderTransform) -> Point -> RenderTransform
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Point
Point (Double -> Rect -> Double
fx Double
t Rect
vp) (Double -> Rect -> Double
fy Double
t Rect
vp)]
fx :: Double -> Rect -> Double
fx Double
t (Rect Double
_ Double
_ Double
w Double
_) = case SlideDirection
dir of
SlideDirection
SlideLeft -> -Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a
step Double
t)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
w
SlideDirection
SlideRight -> (Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a
step Double
t)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
w
SlideDirection
_ -> Double
0
fy :: Double -> Rect -> Double
fy Double
t (Rect Double
_ Double
_ Double
_ Double
h) = case SlideDirection
dir of
SlideDirection
SlideUp -> -Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
*(Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a
step Double
t)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
h
SlideDirection
SlideDown -> (Double -> Double
forall {a}. (Ord a, Fractional a) => a -> a
step Double
t)Double -> Double -> Double
forall a. Num a => a -> a -> a
*Double
h
SlideDirection
_ -> Double
0
step :: a -> a
step a
t = if Bool
isSlideIn
then a
1a -> a -> a
forall a. Num a => a -> a -> a
-(a -> a
forall {a}. (Ord a, Fractional a) => a -> a
fwdStep a
t)
else 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)
dir :: SlideDirection
dir = SlideDirection -> Maybe SlideDirection -> SlideDirection
forall a. a -> Maybe a -> a
fromMaybe SlideDirection
SlideLeft Maybe SlideDirection
_slcDirection
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
_slcTransformCfg
SlideCfg{Maybe SlideDirection
TransformCfg s e
_slcDirection :: forall s e. SlideCfg s e -> Maybe SlideDirection
_slcTransformCfg :: forall s e. SlideCfg s e -> TransformCfg s e
_slcTransformCfg :: TransformCfg s e
_slcDirection :: Maybe SlideDirection
..} = [SlideCfg s e] -> SlideCfg s e
forall a. Monoid a => [a] -> a
mconcat [SlideCfg s e]
configs