{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
module Monomer.Widgets.Animation.Fade (
FadeCfg,
animFadeIn,
animFadeIn_,
animFadeOut,
animFadeOut_
) where
import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (.~), (%~), at)
import Control.Monad (when)
import Data.Default
import Data.Maybe
import Data.Text (Text)
import Data.Typeable (cast)
import GHC.Generics
import qualified Data.Sequence as Seq
import Monomer.Widgets.Container
import Monomer.Widgets.Animation.Types
import qualified Monomer.Lens as L
data FadeCfg e = FadeCfg {
forall e. FadeCfg e -> Maybe Bool
_fdcAutoStart :: Maybe Bool,
forall e. FadeCfg e -> Maybe Millisecond
_fdcDuration :: Maybe Millisecond,
forall e. FadeCfg e -> [e]
_fdcOnFinished :: [e]
} deriving (FadeCfg e -> FadeCfg e -> Bool
forall e. Eq e => FadeCfg e -> FadeCfg e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FadeCfg e -> FadeCfg e -> Bool
$c/= :: forall e. Eq e => FadeCfg e -> FadeCfg e -> Bool
== :: FadeCfg e -> FadeCfg e -> Bool
$c== :: forall e. Eq e => FadeCfg e -> FadeCfg e -> Bool
Eq, Int -> FadeCfg e -> ShowS
forall e. Show e => Int -> FadeCfg e -> ShowS
forall e. Show e => [FadeCfg e] -> ShowS
forall e. Show e => FadeCfg e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FadeCfg e] -> ShowS
$cshowList :: forall e. Show e => [FadeCfg e] -> ShowS
show :: FadeCfg e -> String
$cshow :: forall e. Show e => FadeCfg e -> String
showsPrec :: Int -> FadeCfg e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> FadeCfg e -> ShowS
Show)
instance Default (FadeCfg e) where
def :: FadeCfg e
def = FadeCfg {
_fdcAutoStart :: Maybe Bool
_fdcAutoStart = forall a. Maybe a
Nothing,
_fdcDuration :: Maybe Millisecond
_fdcDuration = forall a. Maybe a
Nothing,
_fdcOnFinished :: [e]
_fdcOnFinished = []
}
instance Semigroup (FadeCfg e) where
<> :: FadeCfg e -> FadeCfg e -> FadeCfg e
(<>) FadeCfg e
fc1 FadeCfg e
fc2 = FadeCfg {
_fdcAutoStart :: Maybe Bool
_fdcAutoStart = forall e. FadeCfg e -> Maybe Bool
_fdcAutoStart FadeCfg e
fc2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. FadeCfg e -> Maybe Bool
_fdcAutoStart FadeCfg e
fc1,
_fdcDuration :: Maybe Millisecond
_fdcDuration = forall e. FadeCfg e -> Maybe Millisecond
_fdcDuration FadeCfg e
fc2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e. FadeCfg e -> Maybe Millisecond
_fdcDuration FadeCfg e
fc1,
_fdcOnFinished :: [e]
_fdcOnFinished = forall e. FadeCfg e -> [e]
_fdcOnFinished FadeCfg e
fc1 forall a. Semigroup a => a -> a -> a
<> forall e. FadeCfg e -> [e]
_fdcOnFinished FadeCfg e
fc2
}
instance Monoid (FadeCfg e) where
mempty :: FadeCfg e
mempty = forall a. Default a => a
def
instance CmbAutoStart (FadeCfg e) where
autoStart_ :: Bool -> FadeCfg e
autoStart_ Bool
start = forall a. Default a => a
def {
_fdcAutoStart :: Maybe Bool
_fdcAutoStart = forall a. a -> Maybe a
Just Bool
start
}
instance CmbDuration (FadeCfg e) Millisecond where
duration :: Millisecond -> FadeCfg e
duration Millisecond
dur = forall a. Default a => a
def {
_fdcDuration :: Maybe Millisecond
_fdcDuration = forall a. a -> Maybe a
Just Millisecond
dur
}
instance CmbOnFinished (FadeCfg e) e where
onFinished :: e -> FadeCfg e
onFinished e
fn = forall a. Default a => a
def {
_fdcOnFinished :: [e]
_fdcOnFinished = [e
fn]
}
data FadeState = FadeState {
FadeState -> Bool
_fdsRunning :: Bool,
FadeState -> Millisecond
_fdsStartTs :: Millisecond
} deriving (FadeState -> FadeState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FadeState -> FadeState -> Bool
$c/= :: FadeState -> FadeState -> Bool
== :: FadeState -> FadeState -> Bool
$c== :: FadeState -> FadeState -> Bool
Eq, Int -> FadeState -> ShowS
[FadeState] -> ShowS
FadeState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FadeState] -> ShowS
$cshowList :: [FadeState] -> ShowS
show :: FadeState -> String
$cshow :: FadeState -> String
showsPrec :: Int -> FadeState -> ShowS
$cshowsPrec :: Int -> FadeState -> ShowS
Show, forall x. Rep FadeState x -> FadeState
forall x. FadeState -> Rep FadeState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FadeState x -> FadeState
$cfrom :: forall x. FadeState -> Rep FadeState x
Generic)
instance Default FadeState where
def :: FadeState
def = FadeState {
_fdsRunning :: Bool
_fdsRunning = Bool
False,
_fdsStartTs :: Millisecond
_fdsStartTs = Millisecond
0
}
animFadeIn :: WidgetEvent e => WidgetNode s e -> WidgetNode s e
animFadeIn :: forall e s. WidgetEvent e => WidgetNode s e -> WidgetNode s e
animFadeIn WidgetNode s e
managed = forall e s.
WidgetEvent e =>
[FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeIn_ forall a. Default a => a
def WidgetNode s e
managed
animFadeIn_ :: WidgetEvent e => [FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeIn_ :: forall e s.
WidgetEvent e =>
[FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeIn_ [FadeCfg e]
configs WidgetNode s e
managed = forall e s.
WidgetEvent e =>
WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode WidgetType
"animFadeIn" forall {s}. Widget s e
widget WidgetNode s e
managed where
config :: FadeCfg e
config = forall a. Monoid a => [a] -> a
mconcat [FadeCfg e]
configs
widget :: Widget s e
widget = forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
True FadeCfg e
config forall a. Default a => a
def
animFadeOut :: WidgetEvent e => WidgetNode s e -> WidgetNode s e
animFadeOut :: forall e s. WidgetEvent e => WidgetNode s e -> WidgetNode s e
animFadeOut WidgetNode s e
managed = forall e s.
WidgetEvent e =>
[FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeOut_ forall a. Default a => a
def WidgetNode s e
managed
animFadeOut_ :: WidgetEvent e => [FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeOut_ :: forall e s.
WidgetEvent e =>
[FadeCfg e] -> WidgetNode s e -> WidgetNode s e
animFadeOut_ [FadeCfg e]
configs WidgetNode s e
managed = forall e s.
WidgetEvent e =>
WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode WidgetType
"animFadeOut" forall {s}. Widget s e
widget WidgetNode s e
managed where
config :: FadeCfg e
config = forall a. Monoid a => [a] -> a
mconcat [FadeCfg e]
configs
widget :: Widget s e
widget = forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
False FadeCfg e
config forall a. Default a => a
def
makeNode
:: WidgetEvent e => WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode :: forall e s.
WidgetEvent e =>
WidgetType -> Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode WidgetType
wType Widget s e
widget WidgetNode s e
managedWidget = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
wType Widget s e
widget
forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFocusable s a => Lens' s a
L.focusable forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
forall a b. a -> (a -> b) -> b
& forall s a. HasChildren s a => Lens' s a
L.children forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Seq a
Seq.singleton WidgetNode s e
managedWidget
makeFade :: WidgetEvent e => Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade :: forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
isFadeIn FadeCfg e
config FadeState
state = forall {s}. Widget s e
widget where
widget :: Widget s e
widget = forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer FadeState
state forall a. Default a => a
def {
containerInit :: ContainerInitHandler s e
containerInit = forall {p} {s}.
HasTimestamp p Millisecond =>
p -> WidgetNode s e -> WidgetResult s e
init,
containerMerge :: ContainerMergeHandler s e FadeState
containerMerge = forall {p} {s} {p}.
p -> WidgetNode s e -> p -> FadeState -> WidgetResult s e
merge,
containerHandleMessage :: ContainerMessageHandler s e
containerHandleMessage = forall {p} {p} {s} {p}.
(Typeable p, HasTimestamp p Millisecond) =>
p -> WidgetNode s e -> p -> p -> Maybe (WidgetResult s e)
handleMessage,
containerRender :: ContainerRenderHandler s e
containerRender = forall {p} {p}.
HasTimestamp p Millisecond =>
p -> p -> Renderer -> IO ()
render,
containerRenderAfter :: ContainerRenderHandler s e
containerRenderAfter = forall {p} {p}. p -> p -> Renderer -> IO ()
renderPost
}
FadeState Bool
running Millisecond
start = FadeState
state
autoStart :: Bool
autoStart = forall a. a -> Maybe a -> a
fromMaybe Bool
False (forall e. FadeCfg e -> Maybe Bool
_fdcAutoStart FadeCfg e
config)
duration :: Millisecond
duration = forall a. a -> Maybe a -> a
fromMaybe Millisecond
500 (forall e. FadeCfg e -> Maybe Millisecond
_fdcDuration FadeCfg e
config)
period :: Millisecond
period = Millisecond
20
steps :: Int
steps = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Millisecond
duration forall a. Integral a => a -> a -> a
`div` Millisecond
period
finishedReq :: WidgetNode s e -> WidgetRequest s e
finishedReq WidgetNode s e
node = forall i s e.
Typeable i =>
WidgetNode s e -> i -> Millisecond -> WidgetRequest s e
delayedMessage WidgetNode s e
node AnimationMsg
AnimationFinished Millisecond
duration
renderReq :: p -> p -> WidgetRequest s e
renderReq p
wenv p
node = forall {s} {e}. WidgetRequest s e
req where
widgetId :: WidgetId
widgetId = p
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
req :: WidgetRequest s e
req = forall s e.
WidgetId -> Millisecond -> Maybe Int -> WidgetRequest s e
RenderEvery WidgetId
widgetId Millisecond
period (forall a. a -> Maybe a
Just Int
steps)
init :: p -> WidgetNode s e -> WidgetResult s e
init p
wenv WidgetNode s e
node = WidgetResult s e
result where
ts :: Millisecond
ts = p
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
isFadeIn FadeCfg e
config (Bool -> Millisecond -> FadeState
FadeState Bool
True Millisecond
ts)
result :: WidgetResult s e
result
| Bool
autoStart = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [forall {s} {e}. WidgetNode s e -> WidgetRequest s e
finishedReq WidgetNode s e
node, forall {p} {a} {p} {s} {e}.
(HasInfo p a, HasWidgetId a WidgetId) =>
p -> p -> WidgetRequest s e
renderReq p
wenv WidgetNode s e
node]
| Bool
otherwise = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node
merge :: p -> WidgetNode s e -> p -> FadeState -> WidgetResult s e
merge p
wenv WidgetNode s e
node p
oldNode FadeState
oldState = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode where
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
isFadeIn FadeCfg e
config FadeState
oldState
handleMessage :: p -> WidgetNode s e -> p -> p -> Maybe (WidgetResult s e)
handleMessage p
wenv WidgetNode s e
node p
target p
message = Maybe (WidgetResult s e)
result where
result :: Maybe (WidgetResult s e)
result = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast p
message forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {p} {s}.
HasTimestamp p Millisecond =>
p -> WidgetNode s e -> AnimationMsg -> WidgetResult s e
handleAnimateMsg p
wenv WidgetNode s e
node
handleAnimateMsg :: p -> WidgetNode s e -> AnimationMsg -> WidgetResult s e
handleAnimateMsg p
wenv WidgetNode s e
node AnimationMsg
msg = WidgetResult s e
result where
widgetId :: WidgetId
widgetId = WidgetNode s e
node forall s a. s -> Getting a s a -> a
^. forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasWidgetId s a => Lens' s a
L.widgetId
ts :: Millisecond
ts = p
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
startState :: FadeState
startState = Bool -> Millisecond -> FadeState
FadeState Bool
True Millisecond
ts
startReqs :: [WidgetRequest s e]
startReqs = [forall {s} {e}. WidgetNode s e -> WidgetRequest s e
finishedReq WidgetNode s e
node, forall {p} {a} {p} {s} {e}.
(HasInfo p a, HasWidgetId a WidgetId) =>
p -> p -> WidgetRequest s e
renderReq p
wenv WidgetNode s e
node]
newNode :: FadeState -> WidgetNode s e
newNode FadeState
newState = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
Bool -> FadeCfg e -> FadeState -> Widget s e
makeFade Bool
isFadeIn FadeCfg e
config FadeState
newState
result :: WidgetResult s e
result = case AnimationMsg
msg of
AnimationMsg
AnimationStart -> forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs (forall {s}.
HasWidget (WidgetNode s e) (Widget s e) =>
FadeState -> WidgetNode s e
newNode FadeState
startState) [WidgetRequest s e]
startReqs
AnimationMsg
AnimationStop -> forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs (forall {s}.
HasWidget (WidgetNode s e) (Widget s e) =>
FadeState -> WidgetNode s e
newNode forall a. Default a => a
def) [forall s e. WidgetId -> WidgetRequest s e
RenderStop WidgetId
widgetId]
AnimationMsg
AnimationFinished
| FadeState -> Bool
_fdsRunning FadeState
state -> forall e s. Typeable e => WidgetNode s e -> [e] -> WidgetResult s e
resultEvts WidgetNode s e
node (forall e. FadeCfg e -> [e]
_fdcOnFinished FadeCfg e
config)
| Bool
otherwise -> forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
node
render :: p -> p -> Renderer -> IO ()
render p
wenv p
node Renderer
renderer = do
Renderer -> IO ()
saveContext Renderer
renderer
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
running forall a b. (a -> b) -> a -> b
$
Renderer -> Double -> IO ()
setGlobalAlpha Renderer
renderer Double
alpha
where
ts :: Millisecond
ts = p
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasTimestamp s a => Lens' s a
L.timestamp
currStep :: Double
currStep = Double -> Double
clampAlpha forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Millisecond
ts forall a. Num a => a -> a -> a
- Millisecond
start) forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Millisecond
duration
alpha :: Double
alpha
| Bool
isFadeIn = Double
currStep
| Bool
otherwise = Double
1 forall a. Num a => a -> a -> a
- Double
currStep
renderPost :: p -> p -> Renderer -> IO ()
renderPost p
wenv p
node Renderer
renderer = do
Renderer -> IO ()
restoreContext Renderer
renderer