{-# 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, pattern None, strokeWidth, toUserUnit)
import Linear.V2 (R1 (_x), R2 (_y), V2 (..))
import Linear.Vector (Additive (lerp), (^*))
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 (Scene, fork, scene, wait)
import Reanimate.Scene.Sprite (Sprite, newSprite, newSpriteA', play, spriteModify, unVar)
import Reanimate.Scene.Var (Var, modifyVar, newVar, readVar, tweenVar)
class Renderable a where
toSVG :: a -> SVG
instance Renderable Tree where
toSVG = id
data Object s a = Object
{ objectSprite :: Sprite s,
objectData :: Var s (ObjectData a)
}
data ObjectData a = ObjectData
{ _oTranslate :: V2 Double,
_oValueRef :: a,
_oSVG :: SVG,
_oContext :: SVG -> SVG,
_oMargin :: (Double, Double, Double, Double),
_oBB :: (Double, Double, Double, Double),
_oOpacity :: Double,
_oShown :: Bool,
_oZIndex :: Int,
_oEasing :: Signal,
_oScale :: Double,
_oScaleOrigin :: V2 Double
}
oTranslate :: Lens' (ObjectData a) (V2 Double)
oTranslate = lens _oTranslate $ \obj val -> obj {_oTranslate = val}
oTranslateX :: Lens' (ObjectData a) Double
oTranslateX = oTranslate . _x
oTranslateY :: Lens' (ObjectData a) Double
oTranslateY = oTranslate . _y
oSVG :: Getter (ObjectData a) SVG
oSVG = to _oSVG
oContext :: Lens' (ObjectData a) (SVG -> SVG)
oContext = lens _oContext $ \obj val -> obj {_oContext = val}
oMargin :: Lens' (ObjectData a) (Double, Double, Double, Double)
oMargin = lens _oMargin $ \obj val -> obj {_oMargin = val}
oBB :: Getter (ObjectData a) (Double, Double, Double, Double)
oBB = to _oBB
oOpacity :: Lens' (ObjectData a) Double
oOpacity = lens _oOpacity $ \obj val -> obj {_oOpacity = val}
oShown :: Lens' (ObjectData a) Bool
oShown = lens _oShown $ \obj val -> obj {_oShown = val}
oZIndex :: Lens' (ObjectData a) Int
oZIndex = lens _oZIndex $ \obj val -> obj {_oZIndex = val}
oEasing :: Lens' (ObjectData a) Signal
oEasing = lens _oEasing $ \obj val -> obj {_oEasing = val}
oScale :: Lens' (ObjectData a) Double
oScale = lens _oScale $ \obj val -> oComputeBB obj {_oScale = val}
oScaleOrigin :: Lens' (ObjectData a) (V2 Double)
oScaleOrigin = lens _oScaleOrigin $ \obj val -> oComputeBB obj {_oScaleOrigin = val}
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)
}
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
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
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
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
oCenterXY :: Lens' (ObjectData a) (V2 Double)
oCenterXY = lens getter setter
where
getter obj =
let minx = obj ^. oBBMinX
miny = obj ^. oBBMinY
w = obj ^. oBBWidth
h = obj ^. oBBHeight
V2 dx dy = obj ^. oTranslate
in V2 (dx + minx + w / 2) (dy + miny + h / 2)
setter obj (V2 dx dy) =
let V2 x y = getter obj
in obj & (oTranslate . _1) +~ dx - x
& (oTranslate . _2) +~ dy - y
oCenterX :: Lens' (ObjectData a) Double
oCenterX = oCenterXY . _x
oCenterY :: Lens' (ObjectData a) Double
oCenterY = oCenterXY . _y
oMarginTop :: Lens' (ObjectData a) Double
oMarginTop = oMargin . _1
oMarginRight :: Lens' (ObjectData a) Double
oMarginRight = oMargin . _2
oMarginBottom :: Lens' (ObjectData a) Double
oMarginBottom = oMargin . _3
oMarginLeft :: Lens' (ObjectData a) Double
oMarginLeft = oMargin . _4
oBBMinX :: Getter (ObjectData a) Double
oBBMinX = oBB . _1
oBBMinY :: Getter (ObjectData a) Double
oBBMinY = oBB . _2
oBBWidth :: Getter (ObjectData a) Double
oBBWidth = oBB . _3
oBBHeight :: Getter (ObjectData a) Double
oBBHeight = oBB . _4
oModify :: Object s a -> (ObjectData a -> ObjectData a) -> Scene s ()
oModify o = modifyVar (objectData o)
oModifyS :: Object s a -> State (ObjectData a) b -> Scene s ()
oModifyS o = oModify o . execState
oRead :: Object s a -> Getting b (ObjectData a) b -> Scene s b
oRead o l = view l <$> readVar (objectData o)
oTween :: Object s a -> Duration -> (Double -> ObjectData a -> ObjectData a) -> Scene s ()
oTween o d fn = do
ease <- oRead o oEasing
tweenVar (objectData o) d (\v t -> fn (ease t) v)
oTweenS :: Object s a -> Duration -> (Double -> State (ObjectData a) b) -> Scene s ()
oTweenS o d fn = oTween o d (execState . fn)
oTweenV :: Renderable a => Object s a -> Duration -> (Double -> a -> a) -> Scene s ()
oTweenV o d fn = oTween o d (\t -> oValue %~ fn t)
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))
oNew :: Renderable a => a -> Scene s (Object s a)
oNew = newObject
newObject :: Renderable a => a -> Scene s (Object s a)
newObject val = do
ref <-
newVar
ObjectData
{ _oTranslate = V2 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 = V2 0 0
}
sprite <- newSprite $ do
~obj@ObjectData {..} <- unVar ref
pure $
if _oShown
then
uncurryV2 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 {..} =
uncurryV2 translate (negate _oScaleOrigin)
. scale _oScale
. uncurryV2 translate _oScaleOrigin
uncurryV2 :: (a -> a -> b) -> V2 a -> b
uncurryV2 fn (V2 a b) = fn a b
oShow :: Object s a -> Scene s ()
oShow o = oModify o $ oShown .~ True
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
oFadeIn :: SVG -> Animation
oFadeIn svg = animate $ \t -> withGroupOpacity t svg
oFadeOut :: SVG -> Animation
oFadeOut = reverseA . oFadeIn
oGrow :: SVG -> Animation
oGrow svg = animate $ \t -> scale t svg
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
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
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
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 %~ lerp t dstLoc
oTweenV m d $ \t -> morphDelta .~ t
oModify m $ oShown .~ False
oModify dst $ oShown .~ True
newtype Circle = Circle {_circleRadius :: Double}
circleRadius :: Lens' Circle Double
circleRadius = iso _circleRadius Circle
instance Renderable Circle where
toSVG (Circle r) = mkCircle r
data Rectangle = Rectangle {_rectWidth :: Double, _rectHeight :: Double}
rectWidth :: Lens' Rectangle Double
rectWidth = lens _rectWidth $ \obj val -> obj {_rectWidth = val}
rectHeight :: Lens' Rectangle Double
rectHeight = lens _rectHeight $ \obj val -> obj {_rectHeight = val}
instance Renderable Rectangle where
toSVG (Rectangle w h) = mkRect w h
data Morph = Morph {_morphDelta :: Double, _morphSrc :: SVG, _morphDst :: SVG}
morphDelta :: Lens' Morph Double
morphDelta = lens _morphDelta $ \obj val -> obj {_morphDelta = val}
morphSrc :: Lens' Morph SVG
morphSrc = lens _morphSrc $ \obj val -> obj {_morphSrc = val}
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
data Camera = Camera
instance Renderable Camera where
toSVG Camera = None
cameraAttach :: Object s Camera -> Object s a -> Scene s ()
cameraAttach cam obj =
spriteModify (objectSprite obj) $ do
camData <- unVar (objectData cam)
return $ \(svg, zindex) ->
let V2 x y = camData ^. oTranslate
ctx =
translate (- x) (- y)
. uncurryV2 translate (camData ^. oScaleOrigin)
. scale (camData ^. oScale)
. uncurryV2 translate (negate $ camData ^. oScaleOrigin)
in (ctx svg, zindex)
cameraFocus :: Object s Camera -> V2 Double -> Scene s ()
cameraFocus cam new = do
origin <- oRead cam oScaleOrigin
t <- oRead cam oTranslate
s <- oRead cam oScale
let newLocation = new - ((new - origin) ^* s + origin - t)
oModifyS cam $ do
oTranslate .= newLocation
oScaleOrigin .= new
cameraSetZoom :: Object s Camera -> Double -> Scene s ()
cameraSetZoom cam s =
oModifyS cam $
oScale .= s
cameraZoom :: Object s Camera -> Duration -> Double -> Scene s ()
cameraZoom cam d s =
oTweenS cam d $ \t ->
oScale %= \v -> fromToS v s t
cameraSetPan :: Object s Camera -> V2 Double -> Scene s ()
cameraSetPan cam location =
oModifyS cam $
oTranslate .= location
cameraPan :: Object s Camera -> Duration -> V2 Double -> Scene s ()
cameraPan cam d pos =
oTweenS cam d $ \t ->
oTranslate %= lerp t pos