reanimate-0.1.0.0: src/Reanimate/Examples.hs
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeFamilies #-}
module Reanimate.Examples where
import Codec.Picture.Types
import Control.Lens ()
import Control.Monad
import qualified Data.Map as M
import Data.Text (Text, pack)
import Graphics.SvgTree as S
import Linear.V2
import Numeric
import Text.Printf
import Reanimate.Combinators
import Reanimate.Diagrams
import Reanimate.LaTeX
import Reanimate.Monad
import Reanimate.Svg
import qualified Data.Colour.Palette.BrewerSet as D
import qualified Diagrams.Backend.SVG as D
import Diagrams.Prelude hiding (Animation, boundingBox,
center, circle, duration,
fontSize, rotate, scale,
translate)
import qualified Diagrams.Prelude as D
import qualified Diagrams.TwoD.Path.LSystem as D
import Debug.Trace
{-
sinewave :: Ani ()
sinewave = proc () -> do
duration 10 -< ()
emit -< toHtml $ mkBackground "black"
idx <- signalOscillate 0 1 -< ()
emit -< do
defs_ $ clipPath_ [id_ "clip"] $ toHtml $
mkRect (Num 0, Num (-height)) (Num $ idx*width) (Num 320)
toHtml $ translate margin height $ withStrokeColor "white" $
withClipPathRef (Ref "clip") $ mkPathText $ renderPathText $ approxFnData 1000 wave
toHtml $ withStrokeColor "white" $
mkLine (Num margin, Num 10) (Num margin, Num 170)
toHtml $ withStrokeColor "white" $
mkLine (Num margin, Num height) (Num (margin+width), Num height)
let (circX, circY) = wave idx
emit -< g_ [transform_ $ Lucid.translate margin height] $
circle_ [num_ cx_ circX, num_ cy_ circY, r_ "3", fill_ "red"]
where
freq = 3; margin = 30; width = 260; height = 90
wave idx = (idx*width, sin (idx*pi*2*freq) * 50)
morph_wave :: Ani ()
morph_wave = proc () -> do
duration 5 -< ()
morph <- signalOscillate 0 1 -< ()
emit -< toHtml $ mkBackground "black"
emit -< toHtml $ withStrokeColor "white" $ mkGroup
[ translate 30 50 $ mkPathText $ renderPathText wave1
, translate 30 130 $ mkPathText $ renderPathText wave2
, translate 30 90 $ mkPathText $ renderPathText $ morphPath wave1 wave2 morph
, mkLine (Num 30, Num 10) (Num 30, Num 170)
, mkLine (Num 30, Num 90) (Num 290, Num 90) ]
where
freq = 3; width = 260
wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20)
wave2 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*(freq*3)) * 20)
morph_wave_circle :: Ani ()
morph_wave_circle = proc t -> do
duration 5 -< ()
idx <- signalOscillate 0 1 -< ()
emit -< toHtml $ withStrokeColor "white" $ mkGroup
[ mkBackground "black"
, translate 30 90 $ mkPathText $ renderPathText $ morphPath circle wave1 idx
, mkLine (Num 30, Num 10) (Num 30, Num 170)
, mkLine (Num 30, Num 90) (Num 290, Num 90) ]
where
freq = 5; width = 260; radius = 50
wave1 = approxFnData 1000 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20)
circle = approxFnData 1000 $ \idx ->
(cos (idx*pi*2+pi/2)*radius + width/2, sin (idx*pi*2+pi/2)*radius)
progressMeters :: Ani ()
progressMeters = proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
annotate' (adjustSpeed 1.0 progressMeter) -< g_ [transform_ $ Lucid.translate 40 20]
annotate' (adjustSpeed 2.0 progressMeter) -< g_ [transform_ $ Lucid.translate 140 20]
annotate' (adjustSpeed 0.5 progressMeter) -< g_ [transform_ $ Lucid.translate 240 20]
emit -< do
text_ [x_ "55", y_ "150", font_size_ "20"
, text_anchor_ "middle"
, fill_ "white"] "1x"
text_ [x_ "155", y_ "150", font_size_ "20"
, text_anchor_ "middle"
, fill_ "white"] "2x"
text_ [x_ "255", y_ "150", font_size_ "20"
, text_anchor_ "middle"
, fill_ "white"] "0.5x"
progressMeter :: Ani ()
progressMeter = loop $ proc () -> do
duration 5 -< ()
h <- signal 0 100 -< ()
emit -< rect_ [ width_ "30", height_ "100", stroke_ "white", stroke_width_ "2", fill_opacity_ "0" ]
emit -< rect_ [ width_ "30", num_ height_ h, stroke_ "white", fill_ "white" ]
returnA -< ()
highlight :: Ani ()
highlight = proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
emit -< do
path_ (commonAttrs "white" ++ [d_ $ renderPathText rect1])
path_ (commonAttrs "white" ++ [d_ $ renderPathText rect2])
path_ (commonAttrs "white" ++ [d_ $ renderPathText rect3])
path_ (commonAttrs "lightblue" ++ [d_ $ renderPathText rect4])
path_ (commonAttrs "yellow" ++ [d_ $ renderPathText rect5])
path_ (commonAttrs "red" ++ [d_ $ renderPathText rect6])
follow
[ mkTransition highlight1 highlight2
, mkTransition highlight2 highlight3
, mkTransition highlight3 highlight4
, mkTransition highlight4 highlight5
, mkTransition highlight5 highlight6
, mkTransition highlight6 highlight1
] -< ()
where
mkTransition from to = pauseAtEnd 1 $ proc () -> do
duration 1 -< ()
s <- signalSCurve 2 0 1 -< ()
let trans = morphPath from to s
emit -<
path_ (highlightAttrs "green" ++ [d_ $ renderPathText trans <> "Z"])
mkRect x y width height =
[ (x,y), (x+width, y), (x+width, y+height), (x,y+height) ]
rect1 = mkRect margin margin w h
rect2 = mkRect (320-margin-w*2) margin (w*2) h
rect3 = mkRect margin (180-margin-h) w h
rect4 = mkRect (320/3) (180-margin-h) w h
rect5 = mkRect (320/3*2-w) (180-margin-h) w h
rect6 = mkRect (320-margin-w) (180-margin-h) w h
highlight1 = mkRect (margin-b) (margin-b) (w+2*b) (h+2*b)
highlight2 = mkRect (320-margin-w*2-b) (margin-b) (w*2+2*b) (h+2*b)
highlight3 = mkRect (320-margin-w-b) (180-margin-h-b) (w+2*b) (h+2*b)
highlight4 = mkRect (320/3*2-w-b) (180-margin-h-b) (320/3+2*b) (h+2*b)
highlight5 = mkRect (320/3-b) (180-margin-h-b) (320/3+2*b) (h+2*b)
highlight6 = mkRect (margin-b) (180-margin-h-b) (320/3+2*b) (h+2*b)
b = 7
margin = 30
w = 30
h = 30
commonAttrs c = [stroke_width_ "2", stroke_ c, fill_ c]
highlightAttrs c = [stroke_width_ "2", stroke_ c, fill_opacity_ "0"]
clip_rect :: Ani ()
clip_rect = proc () -> do
emit -< toHtml $ mkBackground "black"
annotate' $ follow
[ sim
[ sim [ paintStatic prev | prev <- [max 0 (n-4) .. n-1] ]
, sim [ runAni "black" i | i <- [n-4], i>=0 ]
, runAni "white" n ]
| n <- [0..15]
] -< g_ [transform_ $ Lucid.translate (320/2) (180/2)]
where
paintStatic nth = proc () ->
emit -< toHtml $ withStrokeColor "white" $
square (20+nth*10)
runAni color nth = circle_clip $ proc () -> do
duration 1 -< ()
emit -< toHtml $ withStrokeColor color $
square (20+nth*10)
square side = center $ withFillOpacity 0 $ withStrokeWidth (Num 2) $
mkRect (Num 0, Num 0) (Num side) (Num side)
circle_clip :: Ani () -> Ani ()
circle_clip sub = proc () -> do
arc <- signal (pi*2) 0 -< ()
let startX = pack$show$sin 0 * 1000
startY = pack$show$cos 0 * 1000
xPos = pack$show$sin arc * 1000
yPos = pack$show$cos arc * 1000
long = if arc < pi then "1" else "0"
emit -< clipPath_ [id_ $ uniqName] $
path_ [ d_ $ "M "<>startX<>" "<>startY<>" A 1000 1000 0 "<>long<>" 1 "
<>xPos<> " "<>yPos<>" L 0 0 Z"]
annotate' sub -<
g_ [clip_path_ $ "url(#"<>uniqName<>")"]
where
uniqName = "clip" -- XXX: Not very unique?
scaling :: Ani ()
scaling = adjustSpeed 2 $ syncAll
[ proc () ->
annotate' animation -< g_ [transform_ $ Lucid.translate x y <> " " <> Lucid.scale 0.5 0.5]
| x <- [0,160]
, y <- [0,90]
| animation <- [sinewave, morph_wave, highlight, progressMeters]]
label :: String -> Ani ()
label str = proc () -> do
emit -< text_ [x_ "0", y_ "16", font_size_ "16"
, fill_ "white"] (toHtml str)
valentine :: Ani ()
valentine = proc () -> do
follow
[ all_red
, sim [ background
, follow [backgroundDelay, sim [delay 6.4 (fallingLove 0.09)
,delay 4.9 (fallingLove 0.12)
,delay 4.5 (fallingLove 0.88)
,delay 0.3 (fallingLove 0.43)
,delay 5.3 (fallingLove 0.93)
,delay 0.1 (fallingLove 0.80)
,delay 1.1 (fallingLove 0.39)
,delay 2.3 (fallingLove 0.21)
,delay 2.9 (fallingLove 0.77)
,delay 3.4 (fallingLove 0.46)
,delay 6.2 (fallingLove 0.19)
,delay 5.9 (fallingLove 0.53)
,delay 3.2 (fallingLove 0.14)
,delay 7.7 (fallingLove 0.99) ]]
, follow [heart_ani, heart_disappear]
, follow [backgroundDelay, message "", message ""
, message "", message "爱", message ""
, message "", message ""]]
] -<()
where
all_red = proc () -> do
duration 1 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "red"]
background = freezeAtEnd $ proc () -> do
duration 2 -< ()
n <- signal 0 0xFF -< ()
let color = "#FF" ++ hex n ++ hex n
emit -< rect_ [width_ "100%", height_ "100%", fill_ $ pack color]
backgroundDelay = freezeAtEnd $ proc () -> do
duration (animationDuration background-1) -< ()
returnA -< ()
heart_ani = repeatAni 10 $ proc () -> do
duration 1 -< ()
n <- signalOscillateSCurve 2 0.9 1.1 -< ()
annotate' drawHeart -< g_ [transform_ $ Lucid.translate 160 110] . g_ [transform_ $ Lucid.scale n n <> " "]
heart_disappear = proc () -> do
duration 3 -< ()
n <- signal 0.9 10 -< ()
annotate' drawHeart -< g_ [transform_ $ Lucid.translate 160 110] . g_ [transform_ $ Lucid.scale n n <> " "]
white = loop $ proc () -> do
duration 1 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "#FFFFFF"]
fallingLove xPos = proc () -> do
duration 2 -< ()
n <- signal 0 1 -< ()
o <- signalOscillate (-1) 1 -< ()
emit -<
g_ [transform_ $ Lucid.translate (xPos*360) (210*n)] $
g_ [transform_ $ Lucid.rotate (45*o)] $
text_ [font_size_ "18"
,text_anchor_ "middle"
,fill_ "red"] "爱"
message txt = proc () -> do
duration 1 -< ()
o <- signalOscillate 0 1 -< ()
n <- signalOscillateSCurve 2 0.9 1.1 -< ()
emit -<
g_ [transform_ $ Lucid.translate 160 110, num_ opacity_ o] $
g_ [transform_ $ Lucid.scale n n ] $
text_ [x_ "0", y_ "-12", font_size_ "24"
, text_anchor_ "middle"
, fill_ "white"] txt
drawHeart = proc () -> do
emit -<
g_ [transform_ $ Lucid.translate (-170) (-260)] $
g_ [transform_ $ Lucid.rotateAround 225 150 121 <> " " <> Lucid.scale 0.4 0.4] $
path_ ([stroke_ "red", fill_"red", d_ dat])
dat = "M0 200 v-200 h200 a100,100 90 0,1 0,200 a100,100 90 0,1 -200,0 z"
hex n = if n < 0x10 then "0" ++ showHex (round n) ""
else showHex (round n) ""
frequencies :: Ani ()
frequencies = proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
n <- signal 0 2 -< ()
follow -- [drawUpWave
[ drawLine
, drawFirstWave
, drawSecondWave
, drawUpWave
] -< n
where
freqs = [11, 5, 17]; margin = 30; width = 260; height = 90
drawLine = freezeAtEnd $ proc _ -> do
label "drawLine" -< ()
duration 1 -< ()
n <- signal margin (width+margin) -< ()
emit -< do
line_ [ num_ x1_ margin, num_ y1_ height
, num_ x2_ n, num_ y2_ height
, stroke_ "white"]
circle_ [num_ cx_ n, num_ cy_ height, r_ "3", fill_ "red"]
drawFirstWave = freezeAtEnd $ proc move -> do
label "drawFirstWave" -< ()
duration 3 -< ()
n <- signal 0 1 -< ()
emit -< do
g_ [transform_ $ Lucid.translate margin height] $ renderPath $ morphPath line1 (wave1 move) n
let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ]
circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY*n), num_ r_ 3, fill_ "red"]
drawSecondWave = freezeAtEnd $ proc move -> do
label "drawSecondWave" -< ()
duration 3 -< ()
emit -< do
g_ [transform_ $ Lucid.translate margin height] $ renderPath $ wave1 move
let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ]
circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"]
drawUpWave = freezeAtEnd $ proc move -> do
label "drawUpWave" -< ()
duration 2 -< ()
n <- signal 0 1 -< ()
emit -< do
g_ [transform_ $ Lucid.scale 1 (1-0.5*n)] $ do
g_ [transform_ $ Lucid.translate margin height] $ renderPath $ wave1 move
let circleY = sum [ sin ((1+move)*pi*2*freq) * 20 | freq <- freqs ]
circle_ [num_ cx_ (width+margin), num_ cy_ (height+circleY), num_ r_ 3, fill_ "red"]
line1 = approxFnData 1000 $ \idx ->
(idx*width, 0)
wave1 n = approxFnData 1000 $ \idx ->
(idx*width, sum [ sin ((idx+n)*pi*2*freq) * 20 | freq <- freqs ])
latex_basic :: Ani ()
latex_basic = proc () -> do
duration 2 -< ()
s <- signalOscillate 0 1 -< ()
emit -< toHtml $ mkGroup
[ mkBackground "black"
, translate (320/2) (180/2) $ mkGroup
[ withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) text
, withFillColor "white" $ withFillOpacity s text] ]
where
text = scale 4 $ center $ latexAlign
"\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
bezier :: Ani ()
bezier = adjustSpeed 0.4 $ proc () -> do
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
follow
[ orderN [pointA, pointB]
, morph [pointA, pointA, pointB] [pointA, pointC, pointB]
, orderN [pointA, pointC, pointB]
, morph [pointA, pointC, pointB, pointB] [pointA, pointC, pointD, pointB]
, orderN [pointA, pointC, pointD, pointB]
, morph [pointA, pointC, pointD, pointB] [pointA, pointA, pointB, pointB]] -< ()
where
pointA = (70,130); pointB = (270,120); pointC = (30,30); pointD = (250,50)
morph old new = proc () -> do
duration 0.5 -< ()
s <- signal 0 1 -< ()
let new' = map (\(a,b) -> between a b s) (zip old new)
emit -< forM_ (zip new' (tail new')) $ \(a,b) -> do
renderPath $
approxFnData 100 $ \idx ->
between a b idx
emit -< mapM_ secondaryCircleAt new'
emit -< primaryCircleAt (head new')
orderN lst = proc () -> do
duration 2 -< ()
s <- signalOscillate 0 1 -< ()
emit -< primaryCircleAt =<< orderN' (map const lst) s <* mapM_ secondaryCircleAt lst
orderN' [a] s = do
renderPath $ take (round $ 100*s) $ approxFnData 100 $ \idx -> a idx
return (a s)
orderN' lst s = do
forM_ (zip lst (tail lst)) $ \(a,b) -> renderPath $
approxFnData 100 $ \idx ->
between (a s) (b s) idx
let middlePoints = map (\(a,b) -> \idx -> between (a idx) (b idx) idx) (zip lst (tail lst))
orderN' middlePoints s <* mapM_ secondaryCircleAt (map ($s) middlePoints)
secondaryCircleAt (x,y) = circle_ [num_ cx_ x, num_ cy_ y, num_ r_ 3, fill_ "green"]
primaryCircleAt (x,y) = circle_ [num_ cx_ x, num_ cy_ y, num_ r_ 3, fill_ "red"]
between a b _ | a==b = a
between (x1, y1) (x2, y2) idx =
( x1 + idx * (x2 - x1)
, y1 + idx * (x2-x1) * (y2 - y1) / (x2 - x1))
pathSquare :: Ani ()
pathSquare = proc () -> do
duration 2 -< ()
s <- signalOscillate 0 1 -< ()
emit -< rect_ [width_ "100%", height_ "100%", fill_ "black"]
emit -< g_ [stroke_ "white"] $ toHtml (square s)
where
square s = S.PathTree (myPath s)
myPath s = S.defaultSvg
& S.pathDefinition .~ interpolatePathCommands s myPathCmds
myPathCmds =
[ S.MoveTo S.OriginAbsolute [V2 100 100]
, S.LineTo S.OriginAbsolute [V2 200 150]
, S.LineTo S.OriginRelative [V2 (-10) (-100)]
, S.EndPath
]
latex_draw :: Ani ()
latex_draw = pauseAtEnd 1 $ proc () -> do
emit -< toHtml $ mkBackground "black"
drawText `andThen` fillText -< ()
where
msg = "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
glyphs = center $ latexAlign msg
placement = translate (320/2) (180/2) . scale 5
fillText = proc () -> do
duration 1 -< ()
s <- signal 0 1 -< ()
emit -< toHtml $ placement $
withFillColor "white" $ withFillOpacity s $
glyphs
drawText = proc () -> do
duration 2 -< ()
s <- signal 0 1 -< ()
emit -< toHtml $ placement $
withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) $
partialSvg s glyphs
bbox :: Ani ()
bbox = proc () -> do
emit -< toHtml $ mkBackground "black"
duration 5 -< ()
annotate' bbox1 -< g_ [transform_ $ Lucid.translate (320/2-50) (180/2)]
annotate' bbox2 -< g_ [transform_ $ Lucid.translate (320/2+50) (180/2)]
bbox1 :: Ani ()
bbox1 = proc () -> do
s <- signal 0 1 -< ()
emit -< do
toHtml $ mkBoundingBox $ rotate (360*s) svg
toHtml $ withFillColor "white" $ rotate (360*s) svg
where
svg = scale 3 $ center $ latexAlign "\\sum_{k=1}^\\infty"
bbox2 :: Ani ()
bbox2 = proc () -> do
s <- signalOscillate 0 1 -< ()
emit -< do
toHtml $ mkBoundingBox $ partialSvg s heartShape
toHtml $ withStrokeColor "white" $ withFillOpacity 0 $ partialSvg s heartShape
mkBoundingBox :: Tree -> Tree
mkBoundingBox svg = withStrokeColor "red" $ withFillOpacity 0 $
mkRect (S.Num x, S.Num y) (S.Num w) (S.Num h)
where
(x, y, w, h) = boundingBox svg
heartShape =
center $ rotateAroundCenter 225 $ mkPathString
"M0.0,40.0 v-40.0 h40.0\
\a20.0 20.0 90.0 0 1 0.0,40.0\
\a20.0 20.0 90.0 0 1 -40.0,0.0 Z"
latex_color :: Ani ()
latex_color = proc () -> do
duration 0.1 -< ()
emit -< toHtml $ mkBackground "black"
emit -< toHtml $ translate (320/2) (180/2) $ withStrokeWidth (Num 0.2) $
withStrokeColor "white" $
withSubglyphs [0] (withFillColor "blue") $
withSubglyphs [1] (withFillColor "yellow") $
withSubglyphs [2] (withFillColor "green") $
withSubglyphs [3] (withFillColor "red") $
withSubglyphs [4] (withFillColor "darkslategrey") $
svg
where
svg = scale 10 $ center $ latex "\\LaTeX"
-}
latex_draw :: Animation
latex_draw =
bg `sim` (autoReverse $ drawText `andThen` fillText)
where
bg = mkAnimation 0 $ emit (mkBackground "black")
msg = "\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
glyphs = center $ latexAlign msg
fillText = mkAnimation 1 $ do
s <- signal 0 1
emit $ scale 5 $ withFillColor "white" $ withFillOpacity s glyphs
drawText = mkAnimation 2 $ do
s <- signal 0 1
emit $ scale 5 $
withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) $
partialSvg s glyphs
morph_wave :: Animation
morph_wave = autoReverse $ mkAnimation 2.5 $ do
morph <- signal 0 1
emit $ mkBackground "black"
emit $ withStrokeColor "white" $ translate (-320/2) (-180/2) $ mkGroup
[ translate 30 50 $ mkLinePath wave1
, translate 30 130 $ mkLinePath wave2
, translate 30 90 $ mkLinePath $ morphPath wave1 wave2 morph
, mkLine (Num 30, Num 10) (Num 30, Num 170)
, mkLine (Num 30, Num 90) (Num 290, Num 90) ]
where
freq = 3; width = 260
wave1 = approxFnData 100 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20)
wave2 = approxFnData 100 $ \idx -> (idx*width, sin (idx*pi*2*(freq*3)) * 20)
morph_wave_circle :: Animation
morph_wave_circle = autoReverse $ mkAnimation 2.5 $ do
idx <- signal 0 1
emit $ mkBackground "black"
emit $ withStrokeColor "white" $ translate (-320/2) (-180/2) $ mkGroup
[ translate 30 90 $ mkLinePath $ morphPath circle wave1 idx
, mkLine (Num 30, Num 10) (Num 30, Num 170)
, mkLine (Num 30, Num 90) (Num 290, Num 90) ]
where
freq = 5; width = 260; radius = 50
wave1 = approxFnData 100 $ \idx -> (idx*width, sin (idx*pi*2*freq) * 20)
circle = approxFnData 100 $ \idx ->
(cos (idx*pi*2+pi/2)*radius + width/2, sin (idx*pi*2+pi/2)*radius)
progressMeters :: Animation
progressMeters =
bg `sim` labels `sim`
mapA (translate (-100) 0) (adjustSpeed 1.0 progressMeter) `simLoop`
mapA (translate 0 0) (adjustSpeed 2.0 progressMeter) `simLoop`
mapA (translate 100 0) (adjustSpeed 0.5 progressMeter)
where
bg = mkAnimation 0 $ emit $ mkBackground "black"
labels = mkAnimation 0 $ emit $ translate 0 70 $ withFillColor "white" $ mkGroup
[ translate (-100) 0 $ scale 2 $ center $ latex "1x"
, translate 0 0 $ scale 2 $ center $ latex "2x"
, translate 100 0 $ scale 2 $ center $ latex "0.5x"
]
progressMeter :: Animation
progressMeter = mkAnimation 3 $ do
h <- signal 0 100
emit $ center $ mkGroup
[ withStrokeColor "white" $ withStrokeWidth (Num 2) $ withFillOpacity 0 $
mkRect (Num 0, Num 0) (Num 30) (Num 100)
, withFillColor "white" $
mkRect (Num 0, Num 0) (Num 30) (Num h) ]
bbox :: Animation
bbox = bg `sim`
mapA (translate (-50) 0) bbox1 `sim`
mapA (translate 50 0) bbox2
where
bg = mkAnimation 0 $ emit $ mkBackground "black"
bbox1 :: Animation
bbox1 = mkAnimation 5 $ do
s <- signal 0 1
emit $ mkGroup
[ mkBoundingBox $ rotate (360*s) svg
, withFillColor "white" $ rotate (360*s) svg ]
where
svg = scale 3 $ center $ latexAlign "\\sum_{k=1}^\\infty"
bbox2 :: Animation
bbox2 = autoReverse $ mkAnimation 2.5 $ do
s <- signal 0 1
emit $ mkGroup
[ mkBoundingBox $ partialSvg s heartShape
, withStrokeColor "white" $ withFillOpacity 0 $ partialSvg s heartShape ]
mkBoundingBox :: Tree -> Tree
mkBoundingBox svg = withStrokeColor "red" $ withFillOpacity 0 $
mkRect (S.Num x, S.Num y) (S.Num w) (S.Num h)
where
(x, y, w, h) = boundingBox svg
heartShape =
center $ rotateAroundCenter 225 $ mkPathString
"M0.0,40.0 v-40.0 h40.0\
\a20.0 20.0 90.0 0 1 0.0,40.0\
\a20.0 20.0 90.0 0 1 -40.0,0.0 Z"
latex_color :: Animation
latex_color = mkAnimation 1 $ do
emit $ mkBackground "black"
emit $ withStrokeWidth (Num 0.2) $
withStrokeColor "white" $
withSubglyphs [0] (withFillColor "blue") $
withSubglyphs [1] (withFillColor "yellow") $
withSubglyphs [2] (withFillColor "green") $
withSubglyphs [3] (withFillColor "red") $
withSubglyphs [4] (withFillColor "darkslategrey") $
svg
where
svg = scale 10 $ center $ latex "\\LaTeX"
latex_basic :: Animation
latex_basic = autoReverse $ mkAnimation 2 $ do
s <- signal 0 1
emit $ mkGroup
[ mkBackground "black"
, withStrokeColor "white" $ withFillOpacity 0 $ withStrokeWidth (Num 0.1) text
, withFillColor "white" $ withFillOpacity s text ]
where
text = scale 4 $ center $ latexAlign
"\\sum_{k=1}^\\infty {1 \\over k^2} = {\\pi^2 \\over 6}"
valentine :: Animation
valentine =
all_red `before`
( background `sim`
(backgroundDelay `before`
foldr1 sim [ pause p `before` fallingLove x | (p, x) <- falling ]
) `sim`
(heart_ani `before` heart_disappear) `sim`
(pause 5 `before` message ai)
)
where
falling = [(6.4, 0.09), (4.9, 0.12), (4.5, 0.88), (0.3, 0.43), (5.3, 0.93)
,(0.1, 0.80), (1.1, 0.39), (2.3, 0.21), (2.9, 0.77), (3.4, 0.46)
,(6.2, 0.19), (5.9, 0.53), (3.2, 0.14), (7.7, 0.99) ]
ai = center $ xelatex "爱"
all_red = mkAnimation 1 $ emit $ mkBackground "red"
background = mkAnimation 2 $ do
n <- round <$> signal 0 0xFF
emit $ mkBackgroundPixel $ PixelRGBA8 0xFF n n 0xFF
backgroundDelay = pause (duration background-1)
heart_ani = repeatAnimation 10 $ mkAnimation 1 $ do
n <- oscillate $ signalSCurve 2 0.9 1.1
mapF (scale n) $ drawHeart
heart_disappear = mkAnimation 3 $ do
n <- signal 0.9 10
mapF (scale n) drawHeart
fallingLove xPos = mkAnimation 2 $ do
n <- signal (-100) 100
o <- oscillate $ signal (-1) 1
emit $ scale 2 $ withFillColor "red" $
translate ((xPos*2-1)*60) n $ rotate (45*o) ai
message txt = mkAnimation 1 $ do
o <- oscillate $ signal 0 1
n <- oscillate $ signalSCurve 2 0.9 1.1
emit $ scale n $ scale 2 $ withFillColor "white" $ withFillOpacity o txt
drawHeart = emit $ withFillColor "red" $ heartShape
diaSize :: Animation
diaSize = mkAnimation 0.1 $ do
emit $ mkBackground "white"
emit $ translate (-320/2) (-180/2) dSvg
where
dSvg = renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $
D.scale 3 $
D.translate (V2 0 (-30)) $
D.rotate (90 @@ deg) $
D.lwO 0.1 $ D.strokePath (D.getTurtlePath (D.tree3 4))
wavyTree :: Animation
wavyTree = mkAnimation 1 $ do
s <- oscillate $ signal 1 2
emit $ mkBackground "white"
emit $ translate (-320/2) (-180/2) (dSvg s)
where
dSvg s = renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $
D.scale 3 $
D.translate (V2 0 (-30)) $
D.rotate (90 @@ deg) $
D.lwO 0.1 $ D.strokePath (D.getTurtlePath (tree s))
gens = 4
tree s =
D.lSystem gens (s/16 @@ turn) (D.symbols "F") rules
rules = M.fromList [D.rule 'F' "FF-[->F+F+>F]+[+>F->F->F]"]
tangentAndNormal :: Animation
tangentAndNormal = mkAnimation 5 $ do
s <- oscillate $ signalSCurve 2 0 1
emit $ mkBackground "white"
emit $ translate (-320/2) (-180/2) $ renderDiagram $
withEnvelope (D.rect 320 180 :: SvgDiagram) $
D.scale 50 $ D.translate (V2 (-2) (-0.75)) $ dia s
where
dia param =
frame 0.5 $
strokeLocTrail spline
<> mconcat
[ tangentLine
, baselineText "tangent" # D.translate tangentVector
, normalLine
, topLeftText "normal" # D.translate (-normalVector)
, rightAngleSquare
] # moveTo pt # D.fontSize large
where
pts = map p2 [(0,0), (1,1), (2,1), (3,0), (3.5,0)]
spline :: Located (Trail V2 Double)
spline = cubicSpline False pts
pt = atParam spline param
tangentVector :: V2 Double
tangentVector = D.normalize $ tangentAtParam spline param
normalVector = D.normalize $ normalAtParam spline param
symmetricLine :: V2 Double -> SvgDiagram
symmetricLine v = fromOffsets [2 *^ v] # D.center
tangentLine :: SvgDiagram
tangentLine = symmetricLine tangentVector
normalLine = symmetricLine normalVector
rightAngleSquare :: SvgDiagram
rightAngleSquare = square 0.1 # alignBL # D.rotate (signedAngleBetween tangentVector unitX)
drawSunflower :: Animation
drawSunflower = mkAnimation 10 $ do
n <- signal 1 500
rot <- signal 0 45
emit $ mkBackground "black"
emit $ rotate rot $ translate (-320/2) (-180/2)
(dSvg $ round n)
where
cached = [ dSvg n | n <- [0..]]
dSvg n = renderDiagram $ withEnvelope (D.rect 320 180 :: SvgDiagram) $
D.scale 5 $ sunflower n
mkCoords :: [P2 Double]
mkCoords =[coord (fromIntegral i) | i <- [1..]]
where
coord m = p2 $ fromPolar (sqrt m) (2.4 * m)
fromPolar r theta = (r * cos theta, r * sin theta)
floret :: Double -> SvgDiagram
floret r = D.circle 0.6 # lw none # fc (colors !! n)
where
n = floor (1.4 * sqrt r) `mod` 10
colors = black : (reverse $ D.brewerSet D.YlOrBr 9)
sunflower :: Int -> SvgDiagram
sunflower n = frame 4 $ position $ take n $ zip mkCoords florets
where
florets = [ floret (sqrt (fromIntegral i)) | i <- [1 ..]]
mkFilter :: String -> [FilterElement] -> Filter
mkFilter ident fe = defaultSvg & filterChildren .~ fe & attrId .~ Just ident
gooEffect :: Animation
gooEffect = mkAnimation 5 $ do
s <- oscillate $ signal 0 3
emit $ mkBackground "black"
emit $ FilterTree $ mkFilter "blur"
[FEGaussianBlur $ defaultSvg
& gaussianBlurStdDeviationX .~ Num dev
& filterResult .~ Just "blur"
] & filterWidth .~ pure (Percent 3)
& filterX .~ pure (Percent (-1))
& filterHeight .~ pure (Percent 3)
& filterY .~ pure (Percent (-1))
emit $ FilterTree $ mkFilter "goo"
[FEGaussianBlur $ defaultSvg
& gaussianBlurStdDeviationX .~ Num dev
& filterResult .~ Just "blur"
,FEColorMatrix $ defaultSvg
& colorMatrixType .~ Matrix
& colorMatrixValues .~ "1 0 0 0 0 \
\0 1 0 0 0 \
\0 0 1 0 0 \
\0 0 0 " ++ show (sharpness*2) ++ " -" ++ show sharpness
& filterResult .~ pure "goo"
,FEComposite $ defaultSvg
& compositeIn .~ pure SourceGraphic
& compositeIn2 .~ pure (SourceRef "goo")
& compositeOperator .~ CompositeAtop
] & filterWidth .~ pure (Percent 3)
& filterX .~ pure (Percent (-1))
& filterHeight .~ pure (Percent 3)
& filterY .~ pure (Percent (-1))
emit $ translate 0 (-radius*2) $ withFillColor "red" $ mkGroup
[ translate (s*(-radius)) 0 circ
, translate (s*radius) 0 circ
]
emit $ withFillColor "red" $ mkGroup
[ translate (s*(-radius)) 0 circ
, translate (s*radius) 0 circ
]
& filterRef .~ pure (Ref "blur")
emit $ translate 0 (radius*2) $ withFillColor "red" $ set filterRef (pure $ Ref "goo")
$ mkGroup [ translate (s*(-radius)) 0 circ
, translate (s*radius) 0 circ ]
where
sharpness = 60
dev = 10
radius = 30
circ = CircleTree $ defaultSvg
& circleCenter .~ (Num 0, Num 0)
& circleRadius .~ Num radius