content: {-# LANGUAGE ApplicativeDo   #-}
  {-# LANGUAGE PatternSynonyms #-}
  {-# LANGUAGE RankNTypes      #-}
  
  module Reanimate.Scene.Sprite where
  
  import           Control.Monad        (void)
  import           Control.Monad.ST     (ST)
  import           Data.Bifunctor       (Bifunctor (first))
  import           Data.STRef           (STRef, modifySTRef, newSTRef, readSTRef)
  import           Graphics.SvgTree     (pattern None)
  import           Reanimate.Animation  (Animation, Duration, SVG, Sync (SyncStretch), Time, dropA,
                                         duration, getAnimationFrame)
  import           Reanimate.Effect     (Effect, delayE)
  import           Reanimate.Scene.Core (Gen, Scene (M), ZIndex, addGen, fork, liftST, queryNow, scene,
                                         wait)
  import           Reanimate.Scene.Var  (Var (..), newVar, readVar, unpackVar)
  import           Reanimate.Transition (Transition, overlapT)
  import           Reanimate.Ease       (Signal)
  
  -- | Create and render a variable. The rendering will be born at the current timestamp
  --   and will persist until the end of the scene.
  --
  --   Example:
  --
  -- @
  -- do var \<- 'simpleVar' 'Reanimate.Svg.Constructors.mkCircle' 0
  --    'Reanimate.Scene.tweenVar' var 2 $ \\val -> 'Reanimate.fromToS' val ('Reanimate.Constants.screenHeight'/2)
  -- @
  --
  --   <<docs/gifs/doc_simpleVar.gif>>
  simpleVar :: (a -> SVG) -> a -> Scene s (Var s a)
  simpleVar render def = do
    v <- newVar def
    _ <- newSprite $ render <$> unVar v
    return v
  
  -- | Helper function for filtering variables.
  findVar :: (a -> Bool) -> [Var s a] -> Scene s (Var s a)
  findVar _cond [] = error "Variable not found."
  findVar cond (v : vs) = do
    val <- readVar v
    if cond val then return v else findVar cond vs
  
  -- | Play an animation once and then remove it. This advances the clock by the duration of the
  --   animation.
  --
  --   Example:
  --
  -- @
  -- do 'play' 'Reanimate.Builtin.Documentation.drawBox'
  --    'play' 'Reanimate.Builtin.Documentation.drawCircle'
  -- @
  --
  --   <<docs/gifs/doc_play.gif>>
  play :: Animation -> Scene s ()
  play ani = newSpriteA ani >>= destroySprite
  
  -- | Sprites are animations with a given time of birth as well as a time of death.
  --   They can be controlled using variables, tweening, and effects.
  data Sprite s = Sprite Time (STRef s (Time -> Time)) (STRef s (Duration, ST s (Duration -> Duration -> Time -> SVG -> (SVG, ZIndex)))) (Gen s)
  
  -- | Sprite frame generator. Generates frames over time in a stateful environment.
  newtype Frame s a = Frame {unFrame :: ST s (Duration -> Time -> Duration -> Time -> a)}
  
  instance Functor (Frame s) where
    fmap fn (Frame gen) = Frame $ do
      m <- gen
      return (\scene_d real_t d t -> fn $ m scene_d real_t d t)
  
  instance Applicative (Frame s) where
    pure v = Frame $ return (\_ _ _ _ -> v)
    Frame f <*> Frame g = Frame $ do
      m1 <- f
      m2 <- g
      return $ \scene_d real_t d t -> m1 scene_d real_t d t (m2 scene_d real_t d t)
  
  -- | Dereference a variable as a Sprite frame.
  --
  --   Example:
  --
  -- @
  -- do v \<- 'newVar' 0
  --    'newSprite' $ 'Reanimate.Svg.Constructors.mkCircle' \<$\> 'unVar' v
  --    'Reanimate.Scene.tweenVar' v 1 $ \\val -> 'Reanimate.fromToS' val 3
  --    'Reanimate.Scene.tweenVar' v 1 $ \\val -> 'Reanimate.fromToS' val 0
  -- @
  --
  --   <<docs/gifs/doc_unVar.gif>>
  unVar :: Var s a -> Frame s a
  unVar var = Frame $ do
    fn <- unpackVar var
    return $ \_scene_d real_t _d _t -> fn real_t
  
  -- | Dereference seconds since sprite birth.
  spriteT :: Frame s Time
  spriteT = Frame $ return (\_scene_d _real_t _d t -> t)
  
  -- | Dereference duration of the current sprite.
  spriteDuration :: Frame s Duration
  spriteDuration = Frame $ return (\_scene_d _real_t d _t -> d)
  
  -- | Create new sprite defined by a frame generator. Unless otherwise specified using
  --   'destroySprite', the sprite will die at the end of the scene.
  --
  --   Example:
  --
  -- @
  -- do 'newSprite' $ 'Reanimate.Svg.Constructors.mkCircle' \<$\> 'spriteT' -- Circle sprite where radius=time.
  --    'wait' 2
  -- @
  --
  --   <<docs/gifs/doc_newSprite.gif>>
  newSprite :: Frame s SVG -> Scene s (Sprite s)
  newSprite render = do
    s <- newSpritePart render
    addPartToScene s
    return s
  
  -- | Create a new sprite defined by a frame generator, but not showing
  --   as part of the scene. Such sprites can be used hierarchically within
  --   the definitions of other sprites, via the function renderSprite.
  newSpritePart :: Frame s SVG -> Scene s (Sprite s)
  newSpritePart render = do
    now <- queryNow
    tmod <- liftST $ newSTRef id
    ref <- liftST $ newSTRef (-1, return $ \_ad _d _t svg -> (svg, 0))
    return $ Sprite now tmod ref $ do
      fn <- unFrame render
      time_fn <- readSTRef tmod
      (spriteDur, spriteEffectGen) <- readSTRef ref
      spriteEffect <- spriteEffectGen
      return $ \absD absT_ ->
        let absT = time_fn absT_
            relD = (if spriteDur < 0 then absD else spriteDur) - now
            relT = absT - now
            -- Sprite is live [now;duration[
            -- If we're at the end of a scene, sprites
            -- are live: [now;duration]
            -- This behavior is difficult to get right. See the 'bug_*' examples for
            -- automated tests.
            inTimeSlice = relT >= 0 && relT < relD
            isLastFrame = absD == absT && relT == relD
        in if inTimeSlice || isLastFrame
              then spriteEffect absD relD relT (fn absD absT relD relT)
              else (None, 0)
  
  addPartToScene :: Sprite s -> Scene s ()
  addPartToScene (Sprite _ _ _ gen) = addGen gen
  
  -- | Create new sprite defined by a frame generator. The sprite will die at
  --   the end of the scene.
  newSprite_ :: Frame s SVG -> Scene s ()
  newSprite_ = void . newSprite
  
  -- | Create a new sprite from an animation. This advances the clock by the
  --   duration of the animation. Unless otherwise specified using
  --   'destroySprite', the sprite will die at the end of the scene.
  --
  --   Note: If the scene doesn't end immediately after the duration of the
  --   animation, the animation will be stretched to match the lifetime of the
  --   sprite. See 'newSpriteA'' and 'play'.
  --
  --   Example:
  --
  -- @
  -- do 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
  --    'play' 'Reanimate.Builtin.Documentation.drawBox'
  --    'play' $ 'Reanimate.Animation.reverseA' 'Reanimate.Builtin.Documentation.drawBox'
  -- @
  --
  --   <<docs/gifs/doc_newSpriteA.gif>>
  newSpriteA :: Animation -> Scene s (Sprite s)
  newSpriteA = newSpriteA' SyncStretch
  
  -- | Create a new sprite from an animation and specify the synchronization policy. This advances
  --   the clock by the duration of the animation.
  --
  --   Example:
  --
  -- @
  -- do 'fork' $ 'newSpriteA'' 'Reanimate.Animation.SyncFreeze' 'Reanimate.Builtin.Documentation.drawCircle'
  --    'play' 'Reanimate.Builtin.Documentation.drawBox'
  --    'play' $ 'Reanimate.Animation.reverseA' 'Reanimate.Builtin.Documentation.drawBox'
  -- @
  --
  --   <<docs/gifs/doc_newSpriteA'.gif>>
  newSpriteA' :: Sync -> Animation -> Scene s (Sprite s)
  newSpriteA' sync animation =
    newSprite (getAnimationFrame sync animation <$> spriteT <*> spriteDuration)
      <* wait (duration animation)
  
  -- | Create a sprite from a static SVG image.
  --
  --   Example:
  --
  -- @
  -- do 'newSpriteSVG' $ 'Reanimate.Svg.Constructors.mkBackground' "lightblue"
  --    'play' 'Reanimate.Builtin.Documentation.drawCircle'
  -- @
  --
  --   <<docs/gifs/doc_newSpriteSVG.gif>>
  newSpriteSVG :: SVG -> Scene s (Sprite s)
  newSpriteSVG = newSprite . pure
  
  -- | Create a permanent sprite from a static SVG image. Same as `newSpriteSVG`
  --   but the sprite isn't returned and thus cannot be destroyed.
  newSpriteSVG_ :: SVG -> Scene s ()
  newSpriteSVG_ = void . newSpriteSVG
  
  -- | Create a frame context from the source sprite for use within another. Use of this
  --   function allows several sprites to be combined into a single one, with the
  --   method of combination controled by variables.
  renderSprite :: Sprite s -> Frame s SVG
  renderSprite (Sprite _ _ _ gen) =
    Frame $ do
              genFn <- gen
              return (\absD absT _ _ -> fst $ genFn absD absT)
  
  -- | Change the rendering of a sprite using data from a variable. If data from several variables
  --   is needed, use a frame generator instead.
  --
  --   Example:
  --
  -- @
  -- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'
  --    v \<- 'newVar' 0
  --    'applyVar' v s 'Reanimate.Svg.Constructors.rotate'
  --    'Reanimate.Scene.tweenVar' v 2 $ \\val -> 'Reanimate.fromToS' val 90
  -- @
  --
  --   <<docs/gifs/doc_applyVar.gif>>
  applyVar :: Var s a -> Sprite s -> (a -> SVG -> SVG) -> Scene s ()
  applyVar var sprite fn = spriteModify sprite $ do
    varFn <- unVar var
    return $ first $ fn varFn
  
  -- | Destroy a sprite, preventing it from being rendered in the future of the scene.
  --   If 'destroySprite' is invoked multiple times, the earliest time-of-death is used.
  --
  --   Example:
  --
  -- @
  -- do s <- 'newSpriteSVG' $ 'Reanimate.Svg.Constructors.withFillOpacity' 1 $ 'Reanimate.Svg.Constructors.mkCircle' 1
  --    'fork' $ 'wait' 1 \>\> 'destroySprite' s
  --    'play' 'Reanimate.Builtin.Documentation.drawBox'
  -- @
  --
  --   <<docs/gifs/doc_destroySprite.gif>>
  destroySprite :: Sprite s -> Scene s ()
  destroySprite (Sprite _ _tmod ref _) = do
    now <- queryNow
    liftST $
      modifySTRef ref $ \(ttl, render) ->
        (if ttl < 0 then now else min ttl now, render)
  
  -- | Low-level frame modifier.
  spriteModify :: Sprite s -> Frame s ((SVG, ZIndex) -> (SVG, ZIndex)) -> Scene s ()
  spriteModify (Sprite born _tmod ref _) modFn = liftST $
    modifySTRef ref $ \(ttl, renderGen) ->
      ( ttl,
        do
          render <- renderGen
          modRender <- unFrame modFn
          return $ \absD relD relT ->
            let absT = relT + born in modRender absD absT relD relT . render absD relD relT
      )
  
  -- | Apply easing function before rendering sprite.
  signalS :: Sprite s -> Duration -> Signal -> Scene s ()
  signalS (Sprite _born tmod _ref _) dur signal = do
    now <- queryNow
    let modify_t t
          | t < now     = t
          | t > now+dur = t
          | otherwise   = now + signal ((t-now) / dur) * dur
    liftST $
      modifySTRef tmod $ \fn -> modify_t . fn
      
  
  
  -- | Map the SVG output of a sprite.
  --
  --   Example:
  --
  -- @
  -- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
  --    'wait' 1
  --    'spriteMap' s 'Reanimate.Svg.Constructors.flipYAxis'
  -- @
  --
  --   <<docs/gifs/doc_spriteMap.gif>>
  spriteMap :: Sprite s -> (SVG -> SVG) -> Scene s ()
  spriteMap sprite@(Sprite born _ _ _) fn = do
    now <- queryNow
    let tDelta = now - born
    spriteModify sprite $ do
      t <- spriteT
      return $ \(svg, zindex) -> (if (t - tDelta) < 0 then svg else fn svg, zindex)
  
  -- | Modify the output of a sprite between @now@ and @now+duration@.
  --
  --   Example:
  --
  -- @
  -- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
  --    'spriteTween' s 1 $ \\val -> 'Reanimate.Svg.Constructors.translate' ('Reanimate.Constants.screenWidth'*0.3*val) 0
  -- @
  --
  --   <<docs/gifs/doc_spriteTween.gif>>
  spriteTween :: Sprite s -> Duration -> (Double -> SVG -> SVG) -> Scene s ()
  spriteTween sprite@(Sprite born _ _ _) dur fn = do
    now <- queryNow
    let tDelta = now - born
    spriteModify sprite $ do
      t <- spriteT
      return $ first $ \svg -> fn (clamp 0 1 $ (t - tDelta) / dur) svg
    wait dur
    where
      clamp a b v
        | v < a = a
        | v > b = b
        | otherwise = v
  
  -- | Create a new variable and apply it to a sprite.
  --
  --   Example:
  --
  -- @
  -- do s \<- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawBox'
  --    v \<- 'spriteVar' s 0 'Reanimate.Svg.Constructors.rotate'
  --    'Reanimate.Scene.tweenVar' v 2 $ \\val -> 'Reanimate.fromToS' val 90
  -- @
  --
  --   <<docs/gifs/doc_spriteVar.gif>>
  spriteVar :: Sprite s -> a -> (a -> SVG -> SVG) -> Scene s (Var s a)
  spriteVar sprite def fn = do
    v <- newVar def
    applyVar v sprite fn
    return v
  
  -- | Apply an effect to a sprite.
  --
  --   Example:
  --
  -- @
  -- do s <- 'fork' $ 'newSpriteA' 'Reanimate.Builtin.Documentation.drawCircle'
  --    'spriteE' s $ 'Reanimate.Effect.overBeginning' 1 'Reanimate.Effect.fadeInE'
  --    'spriteE' s $ 'Reanimate.Effect.overEnding' 0.5 'Reanimate.Effect.fadeOutE'
  -- @
  --
  --   <<docs/gifs/doc_spriteE.gif>>
  spriteE :: Sprite s -> Effect -> Scene s ()
  spriteE (Sprite born _tmod ref _) effect = do
    now <- queryNow
    liftST $
      modifySTRef ref $ \(ttl, renderGen) ->
        ( ttl,
          do
            render <- renderGen
            return $ \ad d t svg ->
              let (svg', z) = render ad d t svg
               in (delayE (max 0 $ now - born) effect d t svg', z)
        )
  
  -- | Set new ZIndex of a sprite.
  --
  --   Example:
  --
  -- @
  -- do s1 \<- 'newSpriteSVG' $ 'Reanimate.Svg.Constructors.withFillOpacity' 1 $ 'Reanimate.Svg.Constructors.withFillColor' "blue" $ 'Reanimate.Svg.Constructors.mkCircle' 3
  --    'newSpriteSVG' $ 'Reanimate.Svg.Constructors.withFillOpacity' 1 $ 'Reanimate.Svg.Constructors.withFillColor' "red" $ 'Reanimate.Svg.Constructors.mkRect' 8 3
  --    'wait' 1
  --    'spriteZ' s1 1
  --    'wait' 1
  -- @
  --
  --   <<docs/gifs/doc_spriteZ.gif>>
  spriteZ :: Sprite s -> ZIndex -> Scene s ()
  spriteZ (Sprite born _tmod ref _) zindex = do
    now <- queryNow
    liftST $
      modifySTRef ref $ \(ttl, renderGen) ->
        ( ttl,
          do
            render <- renderGen
            return $ \ad d t svg ->
              let (svg', z) = render ad d t svg in (svg', if t < now - born then z else zindex)
        )
  
  -- | Destroy all local sprites at the end of a scene.
  --
  --   Example:
  --
  -- @
  -- do -- the rect lives through the entire 3s animation
  --    'newSpriteSVG_' $ 'Reanimate.Svg.Constructors.translate' (-3) 0 $ 'Reanimate.Svg.Constructors.mkRect' 4 4
  --    'wait' 1
  --    'spriteScope' $ do
  --      -- the circle only lives for 1 second.
  --      local \<- 'newSpriteSVG' $ 'Reanimate.Svg.Constructors.translate' 3 0 $ 'Reanimate.Svg.Constructors.mkCircle' 2
  --      'spriteE' local $ 'Reanimate.Effect.overBeginning' 0.3 'Reanimate.Effect.fadeInE'
  --      'spriteE' local $ 'Reanimate.Effect.overEnding' 0.3 'Reanimate.Effect.fadeOutE'
  --      'wait' 1
  --    'wait' 1
  -- @
  --
  --   <<docs/gifs/doc_spriteScope.gif>>
  spriteScope :: Scene s a -> Scene s a
  spriteScope (M action) = M $ \t -> do
    (a, s, p, gens) <- action t
    return (a, s, p, map (genFn (t + max s p)) gens)
    where
      genFn maxT gen = do
        frameGen <- gen
        return $ \_ t ->
          if t < maxT
            then frameGen maxT t
            else (None, 0)
  
  asAnimation :: (forall s'. Scene s' a) -> Scene s Animation
  asAnimation s = do
    now <- queryNow
    return $ dropA now (scene (wait now >> s))
  
  -- | Apply a transformation with a given overlap. This makes sure
  --   to keep timestamps intact such that events can still be timed
  --   by transcripts.
  transitionO :: Transition -> Double -> (forall s'. Scene s' a) -> (forall s'. Scene s' b) -> Scene s ()
  transitionO t o a b = do
    aA <- asAnimation a
    bA <- fork $ do
      wait (duration aA - o)
      asAnimation b
    play $ overlapT o t aA bA
  