{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecordWildCards #-}
module Reanimate.Scene.Object where

import Control.Lens
import Control.Monad (forM_, void)
import Control.Monad.State (State, execState)
import Data.Monoid ( Last(getLast) )
import Graphics.SvgTree
  ( Number (..),
    Tree,
    strokeWidth,
    toUserUnit,
    pattern None,
  )
import Reanimate.Animation
import Reanimate.Constants (defaultDPI, defaultStrokeWidth)
import Reanimate.Ease (Signal, curveS, fromToS)
import Reanimate.Effect ( applyE, fadeLineOutE, overEnding )
import Reanimate.Math.Balloon ( balloon )
import Reanimate.Morph.Common (morph)
import Reanimate.Morph.Linear (linear)
import Reanimate.Svg

import Reanimate.Scene.Core
import Reanimate.Scene.Sprite
import Reanimate.Scene.Var

-------------------------------------------------------
-- Objects

-- | Objects can be any Haskell structure as long as it can be rendered to SVG.
class Renderable a where
  toSVG :: a -> SVG

instance Renderable Tree where
  toSVG = id

-- | Objects are SVG nodes (represented as Haskell values) with
--   identity, location, and several other properties that can
--   change over time.
data Object s a = Object
  { objectSprite :: Sprite s,
    objectData :: Var s (ObjectData a)
  }

-- | Container for object properties.
data ObjectData a = ObjectData
  { _oTranslate :: (Double, Double),
    _oValueRef :: a,
    _oSVG :: SVG,
    _oContext :: SVG -> SVG,
    -- | Top, right, bottom, left
    _oMargin :: (Double, Double, Double, Double),
    _oBB :: (Double, Double, Double, Double),
    _oOpacity :: Double,
    _oShown :: Bool,
    _oZIndex :: Int,
    _oEasing :: Signal,
    _oScale :: Double,
    _oScaleOrigin :: (Double, Double)
  }

-- Basic lenses

-- FIXME: Maybe 'position' is a better name.

-- | Object position. Default: \<0,0\>
oTranslate :: Lens' (ObjectData a) (Double, Double)
oTranslate = lens _oTranslate $ \obj val -> obj {_oTranslate = val}

-- | Rendered SVG node of an object. Does not include context
--   or object properties. Read-only.
oSVG :: Getter (ObjectData a) SVG
oSVG = to _oSVG

-- | Custom render context. Is applied to the object for every
--   frame that it is shown.
oContext :: Lens' (ObjectData a) (SVG -> SVG)
oContext = lens _oContext $ \obj val -> obj {_oContext = val}

-- | Object margins (top, right, bottom, left) in local units.
oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double)
oMargin = lens _oMargin $ \obj val -> obj {_oMargin = val}

-- | Object bounding-box (minimal X-coordinate, minimal Y-coordinate,
--   width, height). Uses `Reanimate.Svg.BoundingBox.boundingBox`
--   and has the same limitations.
oBB :: Getter (ObjectData a) (Double, Double, Double, Double)
oBB = to _oBB

-- | Object opacity. Default: 1
oOpacity :: Lens' (ObjectData a) Double
oOpacity = lens _oOpacity $ \obj val -> obj {_oOpacity = val}

-- | Toggle for whether or not the object should be rendered.
--   Default: False
oShown :: Lens' (ObjectData a) Bool
oShown = lens _oShown $ \obj val -> obj {_oShown = val}

-- | Object's z-index.
oZIndex :: Lens' (ObjectData a) Int
oZIndex = lens _oZIndex $ \obj val -> obj {_oZIndex = val}

-- | Easing function used when modifying object properties.
--   Default: @'Reanimate.Ease.curveS' 2@
oEasing :: Lens' (ObjectData a) Signal
oEasing = lens _oEasing $ \obj val -> obj {_oEasing = val}

-- | Object's scale. Default: 1
oScale :: Lens' (ObjectData a) Double
oScale = lens _oScale $ \obj val -> oComputeBB obj {_oScale = val}

-- | Origin point for scaling. Default: \<0,0\>
oScaleOrigin :: Lens' (ObjectData a) (Double, Double)
oScaleOrigin = lens _oScaleOrigin $ \obj val -> oComputeBB obj {_oScaleOrigin = val}

-- Smart lenses

-- | Lens for the source value contained in an object.
oValue :: Renderable a => Lens' (ObjectData a) a
oValue = lens _oValueRef $ \obj newVal ->
  let svg = toSVG newVal
   in oComputeBB
        obj
          { _oValueRef = newVal,
            _oSVG = svg
          }

oComputeBB :: ObjectData a -> ObjectData a
oComputeBB obj =
  obj
    { _oBB = boundingBox $ oScaleApply obj (_oSVG obj)
    }

-- | Derived location of the top-most point of an object + margin.
oTopY :: Lens' (ObjectData a) Double
oTopY = lens getter setter
  where
    getter obj =
      let top = obj ^. oMarginTop
          miny = obj ^. oBBMinY
          h = obj ^. oBBHeight
          dy = obj ^. oTranslate . _2
       in dy + miny + h + top
    setter obj val =
      obj & (oTranslate . _2) +~ val - getter obj

-- | Derived location of the bottom-most point of an object + margin.
oBottomY :: Lens' (ObjectData a) Double
oBottomY = lens getter setter
  where
    getter obj =
      let bot = obj ^. oMarginBottom
          miny = obj ^. oBBMinY
          dy = obj ^. oTranslate . _2
       in dy + miny - bot
    setter obj val =
      obj & (oTranslate . _2) +~ val - getter obj

-- | Derived location of the left-most point of an object + margin.
oLeftX :: Lens' (ObjectData a) Double
oLeftX = lens getter setter
  where
    getter obj =
      let left = obj ^. oMarginLeft
          minx = obj ^. oBBMinX
          dx = obj ^. oTranslate . _1
       in dx + minx - left
    setter obj val =
      obj & (oTranslate . _1) +~ val - getter obj

-- | Derived location of the right-most point of an object + margin.
oRightX :: Lens' (ObjectData a) Double
oRightX = lens getter setter
  where
    getter obj =
      let right = obj ^. oMarginRight
          minx = obj ^. oBBMinX
          w = obj ^. oBBWidth
          dx = obj ^. oTranslate . _1
       in dx + minx + w + right
    setter obj val =
      obj & (oTranslate . _1) +~ val - getter obj

-- | Derived location of an object's center point.
oCenterXY :: Lens' (ObjectData a) (Double, Double)
oCenterXY = lens getter setter
  where
    getter obj =
      let minx = obj ^. oBBMinX
          miny = obj ^. oBBMinY
          w = obj ^. oBBWidth
          h = obj ^. oBBHeight
          (dx, dy) = obj ^. oTranslate
       in (dx + minx + w / 2, dy + miny + h / 2)
    setter obj (dx, dy) =
      let (x, y) = getter obj
       in obj & (oTranslate . _1) +~ dx - x
            & (oTranslate . _2) +~ dy - y

-- | Object's top margin.
oMarginTop :: Lens' (ObjectData a) Double
oMarginTop = oMargin . _1

-- | Object's right margin.
oMarginRight :: Lens' (ObjectData a) Double
oMarginRight = oMargin . _2

-- | Object's bottom margin.
oMarginBottom :: Lens' (ObjectData a) Double
oMarginBottom = oMargin . _3

-- | Object's left margin.
oMarginLeft :: Lens' (ObjectData a) Double
oMarginLeft = oMargin . _4

-- | Object's minimal X-coordinate..
oBBMinX :: Getter (ObjectData a) Double
oBBMinX = oBB . _1

-- | Object's minimal Y-coordinate..
oBBMinY :: Getter (ObjectData a) Double
oBBMinY = oBB . _2

-- | Object's width without margin.
oBBWidth :: Getter (ObjectData a) Double
oBBWidth = oBB . _3

-- | Object's height without margin.
oBBHeight :: Getter (ObjectData a) Double
oBBHeight = oBB . _4

-------------------------------------------------------------------------------
-- Object modifiers

-- | Modify object properties.
oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s ()
oModify o = modifyVar (objectData o)

-- | Modify object properties using a stateful API.
oModifyS :: Object s a -> State (ObjectData a) b -> Scene s ()
oModifyS o = oModify o . execState

-- | Query object property.
oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b
oRead o l = view l <$> readVar (objectData o)

-- | Modify object properties over a set duration.
oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s ()
oTween o d fn = do
  -- Read 'easing' var here instead of taking it from 'v'.
  -- This allows different easing functions even at the same timestamp.
  ease <- oRead o oEasing
  tweenVar (objectData o) d (\v t -> fn (ease t) v)

-- | Modify object properties over a set duration using a stateful API.
oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s ()
oTweenS o d fn = oTween o d (execState . fn)

-- | Modify object value over a set duration. This is a convenience function
--   for modifying `oValue`.
oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s ()
oTweenV o d fn = oTween o d (\t -> oValue %~ fn t)

-- | Modify object value over a set duration using a stateful API. This is a
--   convenience function for modifying `oValue`.
oTweenVS :: Renderable a => Object s a -> Duration -> (Double -> State a b) -> Scene s ()
oTweenVS o d fn = oTween o d (\t -> oValue %~ execState (fn t))

-- | Create new object.
oNew :: Renderable a => a -> Scene s (Object s a)
oNew = newObject

-- | Create new object.
newObject :: Renderable a => a -> Scene s (Object s a)
newObject val = do
  ref <-
    newVar
      ObjectData
        { _oTranslate = (0, 0),
          _oValueRef = val,
          _oSVG = svg,
          _oContext = id,
          _oMargin = (0.5, 0.5, 0.5, 0.5),
          _oBB = boundingBox svg,
          _oOpacity = 1,
          _oShown = False,
          _oZIndex = 1,
          _oEasing = curveS 2,
          _oScale = 1,
          _oScaleOrigin = (0, 0)
        }
  sprite <- newSprite $ do
    ~obj@ObjectData {..} <- unVar ref
    pure $
      if _oShown
        then
          uncurry translate _oTranslate $
            oScaleApply obj $
              withGroupOpacity _oOpacity $
                mkGroup [_oContext _oSVG]
        else None
  spriteModify sprite $ do
    ~ObjectData {_oZIndex = z} <- unVar ref
    pure $ \(img, _) -> (img, z)
  return
    Object
      { objectSprite = sprite,
        objectData = ref
      }
  where
    svg = toSVG val

oScaleApply :: ObjectData a -> (SVG -> SVG)
oScaleApply ObjectData {..} =
  uncurry translate (_oScaleOrigin & both %~ negate)
    . scale _oScale
    . uncurry translate _oScaleOrigin

-------------------------------------------------------------------------------
-- Graphical transformations

-- | Instantly show object.
oShow :: Object s a -> Scene s ()
oShow o = oModify o $ oShown .~ True

-- | Instantly hide object.
oHide :: Object s a -> Scene s ()
oHide o = oModify o $ oShown .~ False

oShowWith :: Object s a -> (SVG -> Animation) -> Scene s ()
oShowWith o fn = do
  oModify o $ oShown .~ True
  initSVG <- oRead o oSVG
  let ani = fn initSVG
  oTween o (duration ani) $ \t obj ->
    obj {_oSVG = getAnimationFrame SyncStretch ani t 1}
  oModify o $ \obj -> obj {_oSVG = initSVG}

oHideWith :: Object s a -> (SVG -> Animation) -> Scene s ()
oHideWith o fn = do
  initSVG <- oRead o oSVG
  let ani = fn initSVG
  oTween o (duration ani) $ \t obj ->
    obj {_oSVG = getAnimationFrame SyncStretch ani t 1}
  oModify o $ \obj -> obj {_oSVG = initSVG}
  oModify o $ oShown .~ False

-- | Fade in object over a set duration.
oFadeIn :: SVG -> Animation
oFadeIn svg = animate $ \t -> withGroupOpacity t svg

-- | Fade out object over a set duration.
oFadeOut :: SVG -> Animation
oFadeOut = reverseA . oFadeIn

-- | Scale in object over a set duration.
oGrow :: SVG -> Animation
oGrow svg = animate $ \t -> scale t svg

-- | Scale out object over a set duration.
oShrink :: SVG -> Animation
oShrink = reverseA . oGrow

type Origin = (Double, Double)

svgOrigin :: SVG -> Origin -> (Double, Double)
svgOrigin svg (originX, originY) =
  case boundingBox svg of
    (polyX, polyY, polyWidth, polyHeight) ->
      ( polyX + polyWidth * originX,
        polyY + polyHeight * originY
      )

oScaleIn :: SVG -> Animation
oScaleIn = oScaleIn' (curveS 2) (0.5, 1)

oScaleIn' :: Signal -> Origin -> SVG -> Animation
oScaleIn' easing origin = oStagger' 0.05 $ \svg ->
  let (cx, cy) = svgOrigin svg origin
   in signalA easing $
        mkAnimation 0.3 $ \t ->
          translate cx cy $
            scale t $
              translate
                (- cx)
                (- cy)
                svg

oScaleOut :: SVG -> Animation
oScaleOut = reverseA . oStaggerRev' 0.05 (oScaleIn' (curveS 2) (0.5, 0))

oScaleOut' :: Signal -> Origin -> SVG -> Animation
oScaleOut' easing origin = reverseA . oStaggerRev' 0.05 (oScaleIn' easing origin)

oSim :: (SVG -> Animation) -> SVG -> Animation
oSim = oStagger' 0

-- oSim (oStagger fn) = oSim fn
-- oStagger (oStagger fn) = oStagger fn
oStagger :: (SVG -> Animation) -> SVG -> Animation
oStagger = oStagger' 0.2

oStaggerRev :: (SVG -> Animation) -> SVG -> Animation
oStaggerRev = oStaggerRev' 0.2

oStagger' :: Duration -> (SVG -> Animation) -> SVG -> Animation
oStagger' staggerDelay fn svg = scene $
  forM_ (svgGlyphs svg) $ \(ctx, _attr, node) -> do
    void $ fork $ newSpriteA' SyncFreeze (fn $ ctx node)
    wait staggerDelay

oStaggerRev' :: Duration -> (SVG -> Animation) -> SVG -> Animation
oStaggerRev' staggerDelay fn svg = scene $
  forM_ (reverse $ svgGlyphs svg) $ \(ctx, _attr, node) -> do
    void $ fork $ newSpriteA' SyncFreeze (fn $ ctx node)
    wait staggerDelay

oDraw :: SVG -> Animation
oDraw = oStagger $ \svg -> scene $
  forM_ (svgGlyphs $ pathify svg) $ \(ctx, attr, node) -> do
    let sWidth =
          case toUserUnit defaultDPI <$> getLast (attr ^. strokeWidth) of
            Just (Num d) -> max defaultStrokeWidth d
            _ -> defaultStrokeWidth
    -- wait 1
    play $
      mapA ctx $
        applyE (overEnding fillDur $ fadeLineOutE sWidth) $
          animate $ \t ->
            withStrokeWidth sWidth $
              mkGroup
                [withFillOpacity 0 $ partialSvg t node]
    wait (- fillDur)
    newSpriteA' SyncFreeze $
      mkAnimation fillDur $ \t ->
        withGroupOpacity t $
          mkGroup [ctx node]
  where
    fillDur = 0.3

_oBalloon :: SVG -> Animation
_oBalloon = animate . balloon

-- FIXME: Also transform attributes: 'opacity', 'scale', 'scaleOrigin'.

-- | Morph source object into target object over a set duration.
oTransform :: Object s a -> Object s b -> Duration -> Scene s ()
oTransform src dst d = do
  srcSvg <- oRead src oSVG
  srcCtx <- oRead src oContext
  srcEase <- oRead src oEasing
  srcLoc <- oRead src oTranslate
  oModify src $ oShown .~ False

  dstSvg <- oRead dst oSVG
  dstCtx <- oRead dst oContext
  dstLoc <- oRead dst oTranslate

  m <- newObject $ Morph 0 (srcCtx srcSvg) (dstCtx dstSvg)
  oModifyS m $ do
    oShown .= True
    oEasing .= srcEase
    oTranslate .= srcLoc
  fork $ oTween m d $ \t -> oTranslate %~ moveTo t dstLoc
  oTweenV m d $ \t -> morphDelta .~ t
  oModify m $ oShown .~ False
  oModify dst $ oShown .~ True
  where
    moveTo t (dstX, dstY) (srcX, srcY) =
      (fromToS srcX dstX t, fromToS srcY dstY t)

-------------------------------------------------------------------------------
-- Built-in objects

-- | Basic object mapping to \<circle\/\> in SVG.
newtype Circle = Circle {_circleRadius :: Double}

-- | Circle radius in local units.
circleRadius :: Lens' Circle Double
circleRadius = iso _circleRadius Circle

instance Renderable Circle where
  toSVG (Circle r) = mkCircle r

-- | Basic object mapping to \<rect\/\> in SVG.
data Rectangle = Rectangle {_rectWidth :: Double, _rectHeight :: Double}

-- | Rectangle width in local units.
rectWidth :: Lens' Rectangle Double
rectWidth = lens _rectWidth $ \obj val -> obj {_rectWidth = val}

-- | Rectangle height in local units.
rectHeight :: Lens' Rectangle Double
rectHeight = lens _rectHeight $ \obj val -> obj {_rectHeight = val}

instance Renderable Rectangle where
  toSVG (Rectangle w h) = mkRect w h

-- | Object representing an interpolation between SVG nodes.
data Morph = Morph {_morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG}

-- | Control variable for the interpolation. A value of 0 gives the
--   source SVG and 1 gives the target svg.
morphDelta :: Lens' Morph Double
morphDelta = lens _morphDelta $ \obj val -> obj {_morphDelta = val}

-- | Source shape.
morphSrc :: Lens' Morph SVG
morphSrc = lens _morphSrc $ \obj val -> obj {_morphSrc = val}

-- | Target shape.
morphDst :: Lens' Morph SVG
morphDst = lens _morphDst $ \obj val -> obj {_morphDst = val}

instance Renderable Morph where
  toSVG (Morph t src dst) = morph linear src dst t

-- | Cameras can take control of objects and manipulate them
--   with convenient pan and zoom operations.
data Camera = Camera

instance Renderable Camera where
  toSVG Camera = None

-- | Connect an object to a camera such that
--   camera settings (position, zoom, and rotation) is
--   applied to the object.
--
--   Example
--
-- @
-- do cam \<- 'newObject' 'Camera'
--    circ \<- 'newObject' $ 'Circle' 2
--    'oModifyS' circ $
--      'oContext' .= 'withFillOpacity' 1 . 'withFillColor' "blue"
--    'oShow' circ
--    'cameraAttach' cam circ
--    'cameraZoom' cam 1 2
--    'cameraZoom' cam 1 1
-- @
--
--   <<docs/gifs/doc_cameraAttach.gif>>
cameraAttach :: Object s Camera -> Object s a -> Scene s ()
cameraAttach cam obj =
  spriteModify (objectSprite obj) $ do
    camData <- unVar (objectData cam)
    return $ \(svg, zindex) ->
      let (x, y) = camData ^. oTranslate
          ctx =
            translate (- x) (- y)
              . uncurry translate (camData ^. oScaleOrigin)
              . scale (camData ^. oScale)
              . uncurry translate (camData ^. oScaleOrigin & both %~ negate)
       in (ctx svg, zindex)

-- |
--
--   Example
--
-- @
-- do cam \<- 'newObject' 'Camera'
--    circ \<- 'newObject' $ 'Circle' 2; 'oShow' circ
--    'oModify' circ $ 'oTranslate' .~ (-3,0)
--    box \<- 'newObject' $ 'Rectangle' 4 4; 'oShow' box
--    'oModify' box $ 'oTranslate' .~ (3,0)
--    'cameraAttach' cam circ
--    'cameraAttach' cam box
--    'cameraFocus' cam (-3,0)
--    'cameraZoom' cam 2 2      -- Zoom in
--    'cameraZoom' cam 2 1      -- Zoom out
--    'cameraFocus' cam (3,0)
--    'cameraZoom' cam 2 2      -- Zoom in
--    'cameraZoom' cam 2 1      -- Zoom out
-- @
--
--   <<docs/gifs/doc_cameraFocus.gif>>
cameraFocus :: Object s Camera -> (Double, Double) -> Scene s ()
cameraFocus cam (x, y) = do
  (ox, oy) <- oRead cam oScaleOrigin
  (tx, ty) <- oRead cam oTranslate
  s <- oRead cam oScale
  let newLocation = (x - ((x - ox) * s + ox - tx), y - ((y - oy) * s + oy - ty))
  oModifyS cam $ do
    oTranslate .= newLocation
    oScaleOrigin .= (x, y)

-- | Instantaneously set camera zoom level.
cameraSetZoom :: Object s Camera -> Double -> Scene s ()
cameraSetZoom cam s =
  oModifyS cam $
    oScale .= s

-- | Change camera zoom level over a set duration.
cameraZoom :: Object s Camera -> Duration -> Double -> Scene s ()
cameraZoom cam d s =
  oTweenS cam d $ \t ->
    oScale %= \v -> fromToS v s t

-- | Instantaneously set camera location.
cameraSetPan :: Object s Camera -> (Double, Double) -> Scene s ()
cameraSetPan cam location =
  oModifyS cam $
    oTranslate .= location

-- | Change camera location over a set duration.
cameraPan :: Object s Camera -> Duration -> (Double, Double) -> Scene s ()
cameraPan cam d (x, y) =
  oTweenS cam d $ \t -> do
    oTranslate . _1 %= \v -> fromToS v x t
    oTranslate . _2 %= \v -> fromToS v y t