{-# LANGUAGE RankNTypes #-}

module Reanimate.Scene.Core where

import           Control.Monad.Fix          (MonadFix (..))
import           Control.Monad.ST           (ST, runST)
import           Data.List                  (sortOn)
import           Reanimate.Animation        (Animation, Duration, SVG, Time, mkAnimation)
import           Reanimate.Svg.Constructors (mkGroup)

-- | The ZIndex property specifies the stack order of sprites and animations. Elements
--   with a higher ZIndex will be drawn on top of elements with a lower index.
type ZIndex = Int

-- (seq duration, par duration)
-- [(Time, Animation, ZIndex)]
-- Map Time [(Animation, ZIndex)]
type Gen s = ST s (Duration -> Time -> (SVG, ZIndex))

-- | A 'Scene' represents a sequence of animations and variables
--   that change over time.
newtype Scene s a = M {Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
unM :: Time -> ST s (a, Duration, Duration, [Gen s])}

instance Functor (Scene s) where
  fmap :: (a -> b) -> Scene s a -> Scene s b
fmap a -> b
f Scene s a
action = (Time -> ST s (b, Time, Time, [Gen s])) -> Scene s b
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (b, Time, Time, [Gen s])) -> Scene s b)
-> (Time -> ST s (b, Time, Time, [Gen s])) -> Scene s b
forall a b. (a -> b) -> a -> b
$ \Time
t -> do
    (a
a, Time
d1, Time
d2, [Gen s]
gens) <- Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
forall s a. Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
unM Scene s a
action Time
t
    (b, Time, Time, [Gen s]) -> ST s (b, Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
a, Time
d1, Time
d2, [Gen s]
gens)

instance Applicative (Scene s) where
  pure :: a -> Scene s a
pure a
a = (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a)
-> (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall a b. (a -> b) -> a -> b
$ \Time
_ -> (a, Time, Time, [Gen s]) -> ST s (a, Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Time
0, Time
0, [])
  Scene s (a -> b)
f <*> :: Scene s (a -> b) -> Scene s a -> Scene s b
<*> Scene s a
g = (Time -> ST s (b, Time, Time, [Gen s])) -> Scene s b
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (b, Time, Time, [Gen s])) -> Scene s b)
-> (Time -> ST s (b, Time, Time, [Gen s])) -> Scene s b
forall a b. (a -> b) -> a -> b
$ \Time
t -> do
    (a -> b
f', Time
s1, Time
p1, [Gen s]
gen1) <- Scene s (a -> b) -> Time -> ST s (a -> b, Time, Time, [Gen s])
forall s a. Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
unM Scene s (a -> b)
f Time
t
    (a
g', Time
s2, Time
p2, [Gen s]
gen2) <- Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
forall s a. Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
unM Scene s a
g (Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
s1)
    (b, Time, Time, [Gen s]) -> ST s (b, Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f' a
g', Time
s1 Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
s2, Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
p1 (Time
s1 Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
p2), [Gen s]
gen1 [Gen s] -> [Gen s] -> [Gen s]
forall a. [a] -> [a] -> [a]
++ [Gen s]
gen2)

instance Monad (Scene s) where
  return :: a -> Scene s a
return = a -> Scene s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Scene s a
f >>= :: Scene s a -> (a -> Scene s b) -> Scene s b
>>= a -> Scene s b
g = (Time -> ST s (b, Time, Time, [Gen s])) -> Scene s b
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (b, Time, Time, [Gen s])) -> Scene s b)
-> (Time -> ST s (b, Time, Time, [Gen s])) -> Scene s b
forall a b. (a -> b) -> a -> b
$ \Time
t -> do
    (a
a, Time
s1, Time
p1, [Gen s]
gen1) <- Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
forall s a. Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
unM Scene s a
f Time
t
    (b
b, Time
s2, Time
p2, [Gen s]
gen2) <- Scene s b -> Time -> ST s (b, Time, Time, [Gen s])
forall s a. Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
unM (a -> Scene s b
g a
a) (Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
s1)
    (b, Time, Time, [Gen s]) -> ST s (b, Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, Time
s1 Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
s2, Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
p1 (Time
s1 Time -> Time -> Time
forall a. Num a => a -> a -> a
+ Time
p2), [Gen s]
gen1 [Gen s] -> [Gen s] -> [Gen s]
forall a. [a] -> [a] -> [a]
++ [Gen s]
gen2)

instance MonadFix (Scene s) where
  mfix :: (a -> Scene s a) -> Scene s a
mfix a -> Scene s a
fn = (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a)
-> (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall a b. (a -> b) -> a -> b
$ \Time
t -> ((a, Time, Time, [Gen s]) -> ST s (a, Time, Time, [Gen s]))
-> ST s (a, Time, Time, [Gen s])
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (\(a, Time, Time, [Gen s])
v -> let (a
a, Time
_s, Time
_p, [Gen s]
_gens) = (a, Time, Time, [Gen s])
v in Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
forall s a. Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
unM (a -> Scene s a
fn a
a) Time
t)

-- | Lift ST action into the Scene monad.
liftST :: ST s a -> Scene s a
liftST :: ST s a -> Scene s a
liftST ST s a
action = (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a)
-> (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall a b. (a -> b) -> a -> b
$ \Time
_ -> ST s a
action ST s a
-> (a -> ST s (a, Time, Time, [Gen s]))
-> ST s (a, Time, Time, [Gen s])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> (a, Time, Time, [Gen s]) -> ST s (a, Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Time
0, Time
0, [])

-- | Evaluate the value of a scene.
evalScene :: (forall s. Scene s a) -> a
evalScene :: (forall s. Scene s a) -> a
evalScene forall s. Scene s a
action = (forall s. ST s a) -> a
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s a) -> a) -> (forall s. ST s a) -> a
forall a b. (a -> b) -> a -> b
$ do
  (a
val, Time
_, Time
_, [Gen s]
_) <- Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
forall s a. Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
unM Scene s a
forall s. Scene s a
action Time
0
  a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

-- | Render a 'Scene' to an 'Animation'.
scene :: (forall s. Scene s a) -> Animation
scene :: (forall s. Scene s a) -> Animation
scene forall s. Scene s a
action =
  (forall s. ST s Animation) -> Animation
forall a. (forall s. ST s a) -> a
runST
    ( do
        (a
_, Time
s, Time
p, [Gen s]
gens) <- Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
forall s a. Scene s a -> Time -> ST s (a, Time, Time, [Gen s])
unM Scene s a
forall s. Scene s a
action Time
0
        let dur :: Time
dur = Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
s Time
p
        [Time -> Time -> (SVG, ZIndex)]
genFns <- [Gen s] -> ST s [Time -> Time -> (SVG, ZIndex)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Gen s]
gens
        Animation -> ST s Animation
forall (m :: * -> *) a. Monad m => a -> m a
return (Animation -> ST s Animation) -> Animation -> ST s Animation
forall a b. (a -> b) -> a -> b
$
          Time -> (Time -> SVG) -> Animation
mkAnimation
            Time
dur
            ( \Time
t ->
                [SVG] -> SVG
mkGroup ([SVG] -> SVG) -> [SVG] -> SVG
forall a b. (a -> b) -> a -> b
$
                  ((SVG, ZIndex) -> SVG) -> [(SVG, ZIndex)] -> [SVG]
forall a b. (a -> b) -> [a] -> [b]
map (SVG, ZIndex) -> SVG
forall a b. (a, b) -> a
fst ([(SVG, ZIndex)] -> [SVG]) -> [(SVG, ZIndex)] -> [SVG]
forall a b. (a -> b) -> a -> b
$
                    ((SVG, ZIndex) -> ZIndex) -> [(SVG, ZIndex)] -> [(SVG, ZIndex)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn
                      (SVG, ZIndex) -> ZIndex
forall a b. (a, b) -> b
snd
                      [Time -> Time -> (SVG, ZIndex)
spriteRender Time
dur (Time
t Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
dur) | Time -> Time -> (SVG, ZIndex)
spriteRender <- [Time -> Time -> (SVG, ZIndex)]
genFns]
            )
    )

-- -- | Apply easing function to all render elements created by the scene
-- --   in the timespan from now to the scene duration.
-- --
-- --   Note that this does not affect time as seen by `queryNow` or any
-- --   time-dependent variables or object properties.
-- signalS :: Signal -> Scene s a -> Scene s a
-- signalS signal (M action) = M $ \now -> do
--   (a, s, p, gens) <- action now
--   let action_dur = max s p
--       modify_t t
--         | t < now            = t
--         | t > now+action_dur = t
--         | otherwise          = now + signal ((t-now) / action_dur) * action_dur
--   let applyS gen = do
--         fn <- gen
--         return $ \dur t -> fn dur (modify_t t)
--   return (a, s, p, map applyS gens)

-- | Execute actions in a scene without advancing the clock. Note that scenes do not end before
--   all forked actions have completed.
--
--   Example:
--
-- @
-- do 'fork' $ 'Reanimate.Scene.play' 'Reanimate.Builtin.Documentation.drawBox'
--    'Reanimate.Scene.play' 'Reanimate.Builtin.Documentation.drawCircle'
-- @
--
--   <<docs/gifs/doc_fork.gif>>
fork :: Scene s a -> Scene s a
fork :: Scene s a -> Scene s a
fork (M Time -> ST s (a, Time, Time, [Gen s])
action) = (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a)
-> (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall a b. (a -> b) -> a -> b
$ \Time
t -> do
  (a
a, Time
s, Time
p, [Gen s]
gens) <- Time -> ST s (a, Time, Time, [Gen s])
action Time
t
  (a, Time, Time, [Gen s]) -> ST s (a, Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Time
0, Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
s Time
p, [Gen s]
gens)

-- | Query the current clock timestamp.
--
--   Example:
--
-- @
-- do now \<- 'Reanimate.Scene.play' 'Reanimate.Builtin.Documentation.drawCircle' *\> 'queryNow'
--    'Reanimate.Scene.play' $ 'staticFrame' 1 $ 'scale' 2 $ 'withStrokeWidth' 0.05 $
--      'mkText' $ "Now=" <> T.pack (show now)
-- @
--
--   <<docs/gifs/doc_queryNow.gif>>
queryNow :: Scene s Time
queryNow :: Scene s Time
queryNow = (Time -> ST s (Time, Time, Time, [Gen s])) -> Scene s Time
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (Time, Time, Time, [Gen s])) -> Scene s Time)
-> (Time -> ST s (Time, Time, Time, [Gen s])) -> Scene s Time
forall a b. (a -> b) -> a -> b
$ \Time
t -> (Time, Time, Time, [Gen s]) -> ST s (Time, Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
t, Time
0, Time
0, [])

-- | Advance the clock by a given number of seconds.
--
--   Example:
--
-- @
-- do 'fork' $ 'Reanimate.Scene.play' 'Reanimate.Builtin.Documentation.drawBox'
--    'wait' 1
--    'Reanimate.Scene.play' 'Reanimate.Builtin.Documentation.drawCircle'
-- @
--
--   <<docs/gifs/doc_wait.gif>>
wait :: Duration -> Scene s ()
wait :: Time -> Scene s ()
wait Time
d = (Time -> ST s ((), Time, Time, [Gen s])) -> Scene s ()
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s ((), Time, Time, [Gen s])) -> Scene s ())
-> (Time -> ST s ((), Time, Time, [Gen s])) -> Scene s ()
forall a b. (a -> b) -> a -> b
$ \Time
_ -> ((), Time, Time, [Gen s]) -> ST s ((), Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Time
d, Time
0, [])

-- | Wait until the clock is equal to the given timestamp.
waitUntil :: Time -> Scene s ()
waitUntil :: Time -> Scene s ()
waitUntil Time
tNew = do
  Time
now <- Scene s Time
forall s. Scene s Time
queryNow
  Time -> Scene s ()
forall s. Time -> Scene s ()
wait (Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
0 (Time
tNew Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
now))

-- | Wait until all forked and sequential animations have finished.
--
--   Example:
--
-- @
-- do 'waitOn' $ 'fork' $ 'Reanimate.Scene.play' 'Reanimate.Builtin.Documentation.drawBox'
--    'Reanimate.Scene.play' 'Reanimate.Builtin.Documentation.drawCircle'
-- @
--
--   <<docs/gifs/doc_waitOn.gif>>
waitOn :: Scene s a -> Scene s a
waitOn :: Scene s a -> Scene s a
waitOn (M Time -> ST s (a, Time, Time, [Gen s])
action) = (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a)
-> (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall a b. (a -> b) -> a -> b
$ \Time
t -> do
  (a
a, Time
s, Time
p, [Gen s]
gens) <- Time -> ST s (a, Time, Time, [Gen s])
action Time
t
  (a, Time, Time, [Gen s]) -> ST s (a, Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Time -> Time -> Time
forall a. Ord a => a -> a -> a
max Time
s Time
p, Time
0, [Gen s]
gens)

-- | Change the ZIndex of a scene.
adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
adjustZ :: (ZIndex -> ZIndex) -> Scene s a -> Scene s a
adjustZ ZIndex -> ZIndex
fn (M Time -> ST s (a, Time, Time, [Gen s])
action) = (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a)
-> (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
forall a b. (a -> b) -> a -> b
$ \Time
t -> do
  (a
a, Time
s, Time
p, [Gen s]
gens) <- Time -> ST s (a, Time, Time, [Gen s])
action Time
t
  (a, Time, Time, [Gen s]) -> ST s (a, Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Time
s, Time
p, (Gen s -> Gen s) -> [Gen s] -> [Gen s]
forall a b. (a -> b) -> [a] -> [b]
map Gen s -> Gen s
forall (m :: * -> *) p p a.
Monad m =>
m (p -> p -> (a, ZIndex)) -> m (p -> p -> (a, ZIndex))
genFn [Gen s]
gens)
  where
    genFn :: m (p -> p -> (a, ZIndex)) -> m (p -> p -> (a, ZIndex))
genFn m (p -> p -> (a, ZIndex))
gen = do
      p -> p -> (a, ZIndex)
frameGen <- m (p -> p -> (a, ZIndex))
gen
      (p -> p -> (a, ZIndex)) -> m (p -> p -> (a, ZIndex))
forall (m :: * -> *) a. Monad m => a -> m a
return ((p -> p -> (a, ZIndex)) -> m (p -> p -> (a, ZIndex)))
-> (p -> p -> (a, ZIndex)) -> m (p -> p -> (a, ZIndex))
forall a b. (a -> b) -> a -> b
$ \p
d p
t -> let (a
svg, ZIndex
z) = p -> p -> (a, ZIndex)
frameGen p
d p
t in (a
svg, ZIndex -> ZIndex
fn ZIndex
z)

-- | Query the duration of a scene.
withSceneDuration :: Scene s () -> Scene s Duration
withSceneDuration :: Scene s () -> Scene s Time
withSceneDuration Scene s ()
s = do
  Time
t1 <- Scene s Time
forall s. Scene s Time
queryNow
  Scene s ()
s
  Time
t2 <- Scene s Time
forall s. Scene s Time
queryNow
  Time -> Scene s Time
forall (m :: * -> *) a. Monad m => a -> m a
return (Time
t2 Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
t1)

addGen :: Gen s -> Scene s ()
addGen :: Gen s -> Scene s ()
addGen Gen s
gen = (Time -> ST s ((), Time, Time, [Gen s])) -> Scene s ()
forall s a. (Time -> ST s (a, Time, Time, [Gen s])) -> Scene s a
M ((Time -> ST s ((), Time, Time, [Gen s])) -> Scene s ())
-> (Time -> ST s ((), Time, Time, [Gen s])) -> Scene s ()
forall a b. (a -> b) -> a -> b
$ \Time
_ -> ((), Time, Time, [Gen s]) -> ST s ((), Time, Time, [Gen s])
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Time
0, Time
0, [Gen s
gen])