{-# 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