reanimate 0.3.2.3 → 0.3.3.0

raw patch · 35 files changed

+979/−470 lines, 35 filesdep +randombinary-addedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: random

API changes (from Hackage documentation)

Files

• docs/gifs/doc_identityS.gif binary
• docs/gifs/doc_signalFlat.gif binary
• docs/gifs/doc_signalT.gif binary
• examples/demo_stars.hs +77/−0
• examples/doc_circlePlot.hs +1/−1
• examples/doc_hsvComponents.hs +1/−1
• examples/doc_labComponents.hs +1/−1
• examples/doc_lchComponents.hs +1/−1
• examples/doc_rgbComponents.hs +1/−1
• examples/doc_ternaryPlot.hs +1/−1
• examples/doc_xyzComponents.hs +1/−1
• examples/morphology_color.hs +1/−1
• examples/tangent_and_normal.hs +1/−1
• examples/tut_glue_fourier.hs +1/−1
• examples/tut_glue_physics.hs +1/−1
• examples/voice_advanced.hs +153/−0
• examples/voice_fake.hs +56/−0
• examples/voice_transcript.hs +28/−193
• examples/voice_triggers.hs +67/−0
• reanimate.cabal +5/−4
• src/Reanimate.hs +2/−2
• src/Reanimate/Animation.hs +1/−1
• src/Reanimate/Builtin/Flip.hs +1/−1
• src/Reanimate/ColorComponents.hs +99/−0
• src/Reanimate/Ease.hs +107/−0
• src/Reanimate/Interpolate.hs +0/−99
• src/Reanimate/LaTeX.hs +90/−45
• src/Reanimate/Morph/Common.hs +2/−2
• src/Reanimate/Morph/Linear.hs +1/−1
• src/Reanimate/Morph/Rotational.hs +1/−1
• src/Reanimate/Signal.hs +0/−107
• src/Reanimate/Svg.hs +1/−0
• src/Reanimate/Svg/Unuse.hs +2/−2
• src/Reanimate/Transition.hs +1/−1
• src/Reanimate/Voice.hs +274/−0

binary file changed (absent → 11373 bytes)

binary file changed (absent → 2528 bytes)

binary file changed (absent → 49019 bytes)

@@ -0,0 +1,77 @@+#!/usr/bin/env stack+-- stack runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp #-}+module Main+  ( main+  )+where++import           Reanimate+import           Reanimate.Builtin.Documentation+import           Reanimate.ColorComponents+import           System.Random+import           Data.List+import           Codec.Picture.Types+import qualified Data.Vector                   as V++main :: IO ()+main = reanimate $ sceneAnimation $ do+  newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor+  play $ trails 0.05 starAnimation++starAnimation :: Animation+starAnimation = mkAnimation 10 $ \t ->+  let camZ = t * 4+  in  withStrokeWidth 0 $ rotate (t * 360) $ mkGroup+        [ translate (x / newZ) (y / newZ) $ dot (1 - newZ)+        | (x, y, z) <-+          reverse $ take nStars $ dropWhile (\(_, _, z) -> z < camZ) $ allStars+        , let newZ = z - camZ+        ]+ where+  black = PixelRGB8 0x0 0x0 0x0+  dot o =+    withFillColorPixel+        ( promotePixel+        $ interpolateRGB8 labComponents (dropTransparency rtfdBackgroundColor) black o+        )+      $ mkCircle 0.05++{-# INLINE trails #-}+trails :: Double -> Animation -> Animation+trails trailDur raw = mkAnimation (duration raw) $ \t ->+  let idx = round (t * fromIntegral nFrames)+  in  construct $ reverse [idx - trailFrames .. idx]+ where+  fps = 200+  construct []       = mkGroup []+  construct (x : xs) = mkGroup+    [ withGroupOpacity (fromIntegral trailFrames / fromIntegral (trailFrames + 1))+      $ construct xs+    , getFrame x+    ]+  trailFrames = round (trailDur * fps)+  nFrames     = round (duration raw * fps)+  getFrame idx = frames V.! (idx `mod` nFrames)+  frames = V.fromList+    [ frameAt (fromIntegral i / fromIntegral nFrames * duration raw) raw+    | i <- [0 .. nFrames]+    ]++nStars :: Int+nStars = 1000++stars, allStars :: [(Double, Double, Double)]+allStars = [ (x, y, z + n) | n <- [0 ..], (x, y, z) <- stars ]+stars = sortOn takeZ $ take nStars+  [ (x, y, z)+  | x <- randomRs (-screenWidth/2, screenWidth/2) seedX+  | y <- randomRs (-screenWidth/2, screenWidth/2) seedY+  | z <- randomRs (0, 1) seedZ ]+  where takeZ (_,_,z) = z++seedX, seedY, seedZ :: StdGen+seedX = mkStdGen 0xDEAFBEEF+seedY = mkStdGen 0x12345678+seedZ = mkStdGen 0x87654321

@@ -5,7 +5,7 @@ import Reanimate hiding (raster, hsv) import Reanimate.Builtin.Documentation import Reanimate.Builtin.CirclePlot-import Reanimate.Interpolate+import Reanimate.ColorComponents import Data.Colour.RGBSpace.HSV import Data.Colour.RGBSpace import Data.Colour.SRGB

@@ -3,8 +3,8 @@ module Main(main) where  import Reanimate-import Reanimate.Interpolate import Reanimate.Builtin.Documentation+import Reanimate.ColorComponents import Codec.Picture  main :: IO ()

@@ -3,8 +3,8 @@ module Main(main) where  import Reanimate-import Reanimate.Interpolate import Reanimate.Builtin.Documentation+import Reanimate.ColorComponents import Codec.Picture  main :: IO ()

@@ -3,8 +3,8 @@ module Main(main) where  import Reanimate-import Reanimate.Interpolate import Reanimate.Builtin.Documentation+import Reanimate.ColorComponents import Codec.Picture  main :: IO ()

@@ -3,8 +3,8 @@ module Main(main) where  import Reanimate-import Reanimate.Interpolate import Reanimate.Builtin.Documentation+import Reanimate.ColorComponents import Codec.Picture  main :: IO ()

@@ -5,7 +5,7 @@ import Reanimate hiding (raster) import Reanimate.Builtin.Documentation import Reanimate.Builtin.TernaryPlot-import Reanimate.Interpolate+import Reanimate.ColorComponents import Data.Colour.CIE import Codec.Picture.Types 

@@ -3,8 +3,8 @@ module Main(main) where  import Reanimate-import Reanimate.Interpolate import Reanimate.Builtin.Documentation+import Reanimate.ColorComponents import Codec.Picture  main :: IO ()

@@ -6,7 +6,7 @@  import           Codec.Picture import           Reanimate-import           Reanimate.Interpolate+import           Reanimate.ColorComponents import           Reanimate.Morph.Common import           Reanimate.Morph.Linear 

@@ -14,7 +14,7 @@ import           Reanimate.Diagrams import           Reanimate.Driver              (reanimate) import           Reanimate.Animation-import           Reanimate.Signal+import           Reanimate.Ease import           Reanimate.Svg  

@@ -7,7 +7,7 @@ import           Graphics.SvgTree import           Linear.V2 import           Reanimate-import           Reanimate.Signal+import           Reanimate.Ease import           Codec.Picture  -- layer 3

@@ -11,7 +11,7 @@ import           Reanimate import           Reanimate.Chiphunk import           Reanimate.PolyShape-import           Reanimate.Signal+import           Reanimate.Ease import           System.IO.Unsafe    (unsafePerformIO)  shatter :: Animation

@@ -0,0 +1,153 @@+#!/usr/bin/env stack+-- stack --resolver lts-15.04 runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo #-}+module Main where++import           Control.Monad+import qualified Data.Text                     as T+import           Reanimate+import           Reanimate.Ease+import           Reanimate.Voice+import           Reanimate.Builtin.Documentation+import           Geom2D.CubicBezier                       ( QuadBezier(..)+                                                          , evalBezier+                                                          , Point(..)+                                                          )+import           Graphics.SvgTree                         ( ElementRef(..) )++transcript :: Transcript+transcript = loadTranscript "voice_advanced.txt"++main :: IO ()+main = reanimate $ sceneAnimation $ do+  bg <- newSpriteSVG $ mkBackgroundPixel rtfdBackgroundColor+  spriteZ bg (-100)+  newSpriteSVG_ $ mkGroup+    [withStrokeColor "black" $ mkLine (-screenWidth, 0) (screenWidth, 0)]++  centerTxt <- textHandler++  flashEffect+  circleEffect+  squareEffect+  finalEffect++  waitOn $ forM_ (transcriptWords transcript) $ \tword -> fork $ do+    wait (wordStart tword)+    writeVar centerTxt $ wordReference tword++  wait 2++wordDuration :: TWord -> Double+wordDuration tword = wordEnd tword - wordStart tword++--+finalEffect :: Scene s ()+finalEffect = fork $ do+  let begin  = findWord transcript ["final"] "circles"+      ends   = findWords transcript ["final"] "flash"+      path   = QuadBezier (Point 6 (-radius)) (Point 0 6) (Point (-6) (-radius))+      radius = 0.3+  wait (wordStart begin)+  ss <- fork $ replicateM 3 (circleSprite radius path <* wait 0.2)+  mapM_ (flip spriteZ (-1)) ss+  forM_ (zip ss ends) $ \(s, end) -> fork $ do+    spriteMap s flipXAxis+    wait (wordStart end - wordStart begin)+    destroySprite s++-- square effect+squareEffect :: Scene s ()+squareEffect = fork $ do+  let+    begin = findWord transcript [] "square"+    end   = findWord transcript ["middle"] "square"+    path =+      QuadBezier (Point 6 (-size / 2)) (Point 0 6) (Point (-6) (-size / 2))+    size = 1+  wait (wordStart begin)+  s <- squareSprite size path+  spriteMap s (rotate 180)+  spriteZ s (-1)+  wait (wordStart end + wordDuration end / 2 - wordStart begin)+  destroySprite s++-- circle effect+circleEffect :: Scene s ()+circleEffect = fork $ do+  let begin  = findWord transcript [] "circle"+      end    = findWord transcript ["middle"] "circle"+      path   = QuadBezier (Point 6 (-radius)) (Point 0 6) (Point (-6) (-radius))+      radius = 0.3+  wait (wordStart begin)+  s <- circleSprite radius path+  spriteZ s (-1)+  wait (wordStart end + wordDuration end / 2 - wordStart begin)+  destroySprite s++-- flash effect+flashEffect :: Scene s ()+flashEffect = forM_ (findWords transcript [] "flash") $ \flashWord -> fork $ do+  wait (wordStart flashWord)+  flash <- newSpriteSVG $ mkBackground "black"+  spriteTween flash (wordDuration flashWord)+    $ \t -> withGroupOpacity (fromToS 0 0.7 $ (powerS 2 . reverseS) t)+  wait (wordDuration flashWord)+  destroySprite flash++--------------------------------------------------------------------------+-- Helpers and sprites++textHandler :: Scene s (Var s T.Text)+textHandler = simpleVar render T.empty+ where+  render txt =+    let txtSvg      = translate 0 (-0.25) $ centerX $ latex txt+        activeWidth = svgWidth txtSvg + 0.5+    in  mkGroup+          [ withStrokeWidth 0 $ withFillColorPixel rtfdBackgroundColor $ mkRect+            activeWidth+            1+          , txtSvg+          , withStrokeColor "black"+            $ mkLine (activeWidth / 2, 0.5) (activeWidth / 2, -0.5)+          , withStrokeColor "black"+            $ mkLine (-activeWidth / 2, 0.5) (-activeWidth / 2, -0.5)+          ]++circleSprite :: Double -> QuadBezier Double -> Scene s (Sprite s)+circleSprite radius path = newSprite $ do+  t <- spriteT+  d <- spriteDuration+  pure+    $ let Point x y = evalBezier path (t / d)+      in  mkGroup+            [ mkClipPath "circle-mask"+            $ removeGroups+            $ translate 0 (screenHeight / 2)+            $ withFillColorPixel rtfdBackgroundColor+            $ mkRect screenWidth screenHeight+            , withClipPathRef (Ref "circle-mask") $ translate x y $ mkCircle+              radius+            ]++squareSprite :: Double -> QuadBezier Double -> Scene s (Sprite s)+squareSprite size path = newSprite $ do+  t <- spriteT+  d <- spriteDuration+  pure+    $ let Point x y = evalBezier path (t / d)+      in  mkGroup+            [ mkClipPath "square-mask"+            $ removeGroups+            $ translate 0 (screenHeight / 2)+            $ withFillColorPixel rtfdBackgroundColor+            $ mkRect screenWidth screenHeight+            , withClipPathRef (Ref "square-mask")+            $ translate x y+            $ rotate (t / d * 360)+            $ withFillOpacity 0+            $ withStrokeColor "black"+            $ mkRect size size+            ]

@@ -0,0 +1,56 @@+#!/usr/bin/env stack+-- stack --resolver lts-15.04 runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo #-}+module Main where++import           Control.Monad+import qualified Data.Text                     as T+import           Reanimate+import           Reanimate.Voice+import           Reanimate.Builtin.Documentation+import           Graphics.SvgTree                         ( ElementRef(..) )++transcript :: Transcript+transcript =+  fakeTranscript+    "There is no audio\n\n\+    \for this transcript....\n\n\n\+    \Timings are fake,\n\n\+    \which is quite useful\n\n\+    \during development"++main :: IO ()+main = reanimate $ sceneAnimation $ do+  newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor+  waitOn $ forM_ (splitTranscript transcript) $ \(svg, tword) -> do+    highlighted <- newVar 0+    void $ newSprite $ do+      v <- unVar highlighted+      pure $ centerUsing (latex $ transcriptText transcript) $ masked+        (wordKey tword)+        v+        svg+        (withFillColor "grey" $ mkRect 1 1)+        (withFillColor "black" $ mkRect 1 1)+    fork $ do+      wait (wordStart tword)+      let dur = wordEnd tword - wordStart tword+      tweenVar highlighted dur $ \v -> fromToS v 1+  wait 2+ where+  wordKey tword =+    T.unpack (wordReference tword) ++ show (wordStartOffset tword)++{-# INLINE masked #-}+masked :: String -> Double -> SVG -> SVG -> SVG -> SVG+masked key t maskSVG srcSVG dstSVG = mkGroup+  [ mkClipPath label $ removeGroups maskSVG+  , withClipPathRef (Ref label)+    $ translate (x - w / 2 + w * t) y (scaleToSize w screenHeight dstSVG)+  , withClipPathRef (Ref label)+    $ translate (x + w / 2 + w * t) y (scaleToSize w screenHeight srcSVG)+  ]+ where+  label         = "word-mask-" ++ key+  (x, y, w, _h) = boundingBox maskSVG

@@ -2,213 +2,48 @@ -- stack --resolver lts-15.04 runghc --package reanimate {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE RecordWildCards #-} module Main where -import           Codec.Picture.Types import           Control.Monad-import           Data.Hashable-import           Data.Aeson-import           Data.Char-import           System.IO.Unsafe-import           Data.Function-import           Data.List-import           Data.Maybe-import           Data.Ratio import qualified Data.Text                     as T-import           Data.Tuple-import qualified Data.Vector                   as V-import           Debug.Trace import           Reanimate-import           Reanimate.Animation-import           Reanimate.Interpolate-import           Reanimate.Svg-import           Graphics.SvgTree                         ( Texture(..)-                                                          , ElementRef(..)-                                                          )--data Transcript = Transcript-  { transcriptText  :: T.Text-  , transcriptWords :: [TWord]-  } deriving (Show)--instance FromJSON Transcript where-  parseJSON =-    withObject "transcript" $ \o -> Transcript <$> o .: "transcript" <*> o .: "words"--data TWord = TWord-  { wordAligned     :: T.Text-  , wordCase        :: T.Text-  , wordStart       :: Double-  , wordStartOffset :: Int-  , wordEnd         :: Double-  , wordEndOffset   :: Int-  , wordPhones      :: [Phone]-  , wordReference   :: T.Text-  } deriving (Show)--instance FromJSON TWord where-  parseJSON = withObject "word" $ \o ->-    TWord-      <$> o-      .:? "alignedWord"-      .!= T.empty-      <*> o-      .:  "case"-      <*> o-      .:? "start"-      .!= 0-      <*> o-      .:  "startOffset"-      <*> o-      .:? "end"-      .!= 0-      <*> o-      .:  "endOffset"-      <*> o-      .:? "phones"-      .!= []-      <*> o-      .:  "word"--data Phone = Phone-  { phoneDuration :: Double-  , phoneType     :: T.Text-  } deriving (Show)--instance FromJSON Phone where-  parseJSON = withObject "phone" $ \o -> Phone <$> o .: "duration" <*> o .: "phone"---- transcript :: Transcript--- transcript = case unsafePerformIO (decodeFileStrict "voice_transcript.json") of---   Nothing -> error "bad json"---   Just t  -> t+import           Reanimate.Voice+import           Reanimate.Builtin.Documentation+import           Graphics.SvgTree                         ( ElementRef(..) )  transcript :: Transcript-transcript = fakeTranscript-  "This is a fake transcript.\n\n\n\-  \No audio has been recorded\n\n\-  \and the timings are guessed."--data Token = TokenWord Int Int T.Text | TokenComma | TokenPeriod | TokenParagraph-  deriving (Show)--lexText :: T.Text -> [Token]-lexText = worker 0- where-  worker offset txt = case T.uncons txt of-    Nothing -> []-    Just (c, cs)-      | isSpace c-      -> let (w, rest) = T.span (== '\n') txt-         in  if T.length w >= 3-               then TokenParagraph : worker (offset + T.length w) rest-               else worker (offset + 1) cs-      | c == '.'-      -> TokenPeriod : worker (offset + 1) cs-      | c == ','-      -> TokenComma : worker (offset + 1) cs-      | isAlphaNum c-      -> let (w, rest) = T.span isAlphaNum txt-             newOffset = offset + T.length w-         in  TokenWord offset newOffset w : worker newOffset rest-      | otherwise-      -> worker (offset + 1) cs--fakeTranscript :: T.Text -> Transcript-fakeTranscript input = Transcript { transcriptText  = input-                                  , transcriptWords = worker 0 (lexText input)-                                  }- where-  worker now []             = []-  worker now (token : rest) = case token of-    TokenWord start end w ->-      let duration = realToFrac (end-start) * 0.1-      in  TWord { wordAligned     = T.toLower w-                , wordCase        = "success"-                , wordStart       = now-                , wordStartOffset = start-                , wordEnd         = now + duration-                , wordEndOffset   = end-                , wordPhones      = []-                , wordReference   = w-                }-            : worker (now + duration) rest-    TokenComma     -> worker (now + commaPause) rest-    TokenPeriod    -> worker (now + periodPause) rest-    TokenParagraph -> worker (now + paragraphPause) rest-  wpm            = 130-  paragraphPause = 0.5-  commaPause     = 0.1-  periodPause    = 0.2---- tweenVar :: Var s a -> Duration -> (a -> Time -> a) -> Scene s ()--- interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8)-toColor :: String -> PixelRGBA8-toColor c = case mkColor c of-  ColorRef pixel -> pixel+transcript = loadTranscript "voice_transcript.txt"  main :: IO () main = reanimate $ sceneAnimation $ do-  newSpriteSVG_ $ mkBackground "black"-  waitOn $ forM_ (transcriptGlyphs transcript) $ \(svg, tword) -> do+  newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor+  waitOn $ forM_ (splitTranscript transcript) $ \(svg, tword) -> fork $ do     highlighted <- newVar 0-    s <- newSprite $ do+    newSprite_ $ do       v <- unVar highlighted-      pure $ translate (-2) 2 $ scale 0.5 $ mkGroup-        [ maskedIn v svg (withFillColor "white" $ mkRect (svgWidth svg) screenHeight)-        , maskedOut v svg (withFillColor "grey" $ mkRect (svgWidth svg) screenHeight)-        ]-    fork $ do-      wait (wordStart tword)-      let dur = wordEnd tword - wordStart tword-      tweenVar highlighted dur $ \v -> fromToS v 1+      pure $ centerUsing (latex $ transcriptText transcript) $ masked+        (wordKey tword)+        v+        svg+        (withFillColor "grey" $ mkRect 1 1)+        (withFillColor "black" $ mkRect 1 1)+    wait (wordStart tword)+    let dur = wordEnd tword - wordStart tword+    tweenVar highlighted dur $ \v -> fromToS v 1   wait 2--maskedIn :: Double -> SVG -> SVG -> SVG-maskedIn t maskSVG targetSVG = mkGroup-  [ mkClipPath label $ removeGroups maskSVG-  , withClipPathRef (Ref label) $ translate (x-w/2 + w * t) y targetSVG-  ]-  where-    label = "word-mask-" ++ show (hash $ renderTree maskSVG)-    (x, y, w, _h) = boundingBox maskSVG+ where+  wordKey tword =+    T.unpack (wordReference tword) ++ show (wordStartOffset tword) -maskedOut :: Double -> SVG -> SVG -> SVG-maskedOut t maskSVG targetSVG = mkGroup+{-# INLINE masked #-}+masked :: String -> Double -> SVG -> SVG -> SVG -> SVG+masked key t maskSVG srcSVG dstSVG = mkGroup   [ mkClipPath label $ removeGroups maskSVG-  , withClipPathRef (Ref label) $ translate (x+w/2 + w * t) y targetSVG+  , withClipPathRef (Ref label)+    $ translate (x - w / 2 + w * t) y (scaleToSize w screenHeight dstSVG)+  , withClipPathRef (Ref label)+    $ translate (x + w / 2 + w * t) y (scaleToSize w screenHeight srcSVG)   ]-  where-    label = "word-mask-" ++ show (hash (renderTree maskSVG, renderTree targetSVG))-    (x, y, w, _h) = boundingBox maskSVG---- svgGlyphs :: Tree -> [(Tree -> Tree, DrawAttributes, Tree)]-transcriptGlyphs :: Transcript -> [(SVG, TWord)]-transcriptGlyphs Transcript {..}-  | T.length textSymbols /= length gls-  = error "Bad size"-  | otherwise-  = [ ( mkGroup $ take (wordEndOffset - wordStartOffset) $ drop-        (wordStartOffset - spaces)-        gls-      , tword-      )-    | tword@TWord {..} <- transcriptWords-    , let spaces = nSpaces wordStartOffset-    ]  where-  nSpaces limit = T.length (T.filter isSpace (T.take limit transcriptText))-  textSymbols = T.filter (not . isSpace) transcriptText-  total       = center $ simplify $ latex transcriptText-  gls         = [ ctx g | (ctx, _attr, g) <- svgGlyphs total ]--forceLayout txt =-  fst $ splitGlyphs [0, 1, 2, 3] (latex $ "\\fbox{\\phantom{TyhILW}}" <> txt)--alignText :: SVG -> SVG-alignText txt = translate 0 (svgHeight ref / 2) $ centerX txt-  where ref = latex "\\fbox{Thy}"---- abc, width=14.92 height=7.02--- Thy, width=32.73 height=8.95+  label         = "word-mask-" ++ key+  (x, y, w, _h) = boundingBox maskSVG

@@ -0,0 +1,67 @@+#!/usr/bin/env stack+-- stack --resolver lts-15.04 runghc --package reanimate+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo #-}+module Main where++import           Control.Monad+import qualified Data.Text                     as T+import           Reanimate+import           Reanimate.Voice+import           Reanimate.Builtin.Documentation+import           Graphics.SvgTree                         ( ElementRef(..) )++transcript :: Transcript+transcript = loadTranscript "voice_triggers.txt"++transformer :: SVG -> SVG+transformer = scale 1 . translate (-4) 0 . centerUsing (latex $ transcriptText transcript)++main :: IO ()+main = reanimate $ sceneAnimation $ do+  newSpriteSVG_ $ mkBackgroundPixel rtfdBackgroundColor+  waitOn $ forM_ (splitTranscript transcript) $ \(svg, tword) -> do+    highlighted <- newVar 0+    void $ newSprite $ do+      v <- unVar highlighted+      pure $ transformer $ masked (wordKey tword)+                                  v+                                  svg+                                  (withFillColor "grey" $ mkRect 1 1)+                                  (withFillColor "black" $ mkRect 1 1)+    let dur = wordEnd tword - wordStart tword+    fork $ do+      wait (wordStart tword)+      tweenVar highlighted dur $ \v -> fromToS v 1+    fork $ do+      wait (wordStart tword)+      case wordReference tword of+        "one"   -> highlight dur $ latex "1"+        "two"   -> highlight dur $ latex "2"+        "three" -> highlight dur $ latex "3"+        "red"   -> highlight dur $ withFillColor "red" $ mkCircle 1+        "green" -> highlight dur $ withFillColor "green" $ mkCircle 1+        "blue"  -> highlight dur $ withFillColor "blue" $ mkCircle 1+        _       -> return ()+  wait 2+ where+  wordKey tword = T.unpack (wordReference tword) ++ show (wordStartOffset tword)+  highlight dur img =+    play+      $ animate+          (\t -> translate (screenWidth / 4) 0 $ scale t $ scaleToHeight 4 $ center img)+      # signalA (bellS 2)+      # setDuration dur++{-# INLINE masked #-}+masked :: String -> Double -> SVG -> SVG -> SVG -> SVG+masked key t maskSVG srcSVG dstSVG = mkGroup+  [ mkClipPath label $ removeGroups maskSVG+  , withClipPathRef (Ref label)+    $ translate (x - w / 2 + w * t) y (scaleToSize w screenHeight dstSVG)+  , withClipPathRef (Ref label)+    $ translate (x + w / 2 + w * t) y (scaleToSize w screenHeight srcSVG)+  ]+ where+  label         = "word-mask-" ++ key+  (x, y, w, _h) = boundingBox maskSVG

@@ -3,7 +3,7 @@ --  see http://haskell.org/cabal/users-guide/  name:                reanimate-version:             0.3.2.3+version:             0.3.3.0 -- synopsis: -- description: license:             PublicDomain@@ -52,7 +52,7 @@   default-extensions: PackageImports   exposed-modules:    Reanimate                       Reanimate.Animation-                      Reanimate.Signal+                      Reanimate.Ease                       Reanimate.Render                       Reanimate.LaTeX                       Reanimate.Svg@@ -80,9 +80,9 @@                       Reanimate.Morph.LineBend                       Reanimate.Morph.Cache                       Reanimate.Raster+                      Reanimate.ColorComponents                       Reanimate.ColorMap                       Reanimate.ColorSpace-                      Reanimate.Interpolate                       Reanimate.Memo                       Reanimate.Scene                       Reanimate.Povray@@ -99,6 +99,7 @@                       Reanimate.GeoProjection                       Reanimate.Builtin.Documentation                       Reanimate.Builtin.Images+                      Reanimate.Voice   other-modules:      Reanimate.Cache                       Reanimate.Driver                       Reanimate.Driver.Check@@ -111,7 +112,7 @@                        containers, reanimate-svg >= 0.9.7.0, xml, bytestring, lens, linear, mtl, matrix,                        JuicyPixels, attoparsec, parallel,                        cubicbezier, websockets >= 0.12.7.0,-                       hashable, fsnotify, open-browser, random-shuffle, base64-bytestring,+                       hashable, fsnotify, open-browser, random, random-shuffle, base64-bytestring,                        vector >= 0.12.0.0, colour, cassava, ansi-wl-pprint, here, temporary,                        optparse-applicative, chiphunk >= 0.1.2.1,                        geojson, aeson >= 1.3.0.0,

@@ -63,7 +63,7 @@     freezeAtPercentage,     addStatic,     signalA,-    -- ** Signals+    -- ** Easing functions     Signal,     constantS,     fromToS,@@ -197,7 +197,7 @@ import           Reanimate.Raster import           Reanimate.Effect import           Reanimate.Scene-import           Reanimate.Signal+import           Reanimate.Ease import           Reanimate.Svg import           Reanimate.Svg.BoundingBox import           Reanimate.Svg.Constructors

@@ -51,7 +51,7 @@                                              Tree (..), xmlOfTree) import           Graphics.SvgTree.Printer import           Reanimate.Constants-import           Reanimate.Signal+import           Reanimate.Ease import           Reanimate.Svg.Constructors import           Text.XML.Light.Output 

@@ -14,7 +14,7 @@ import           Reanimate.Blender import           Reanimate.Raster import           Reanimate.Scene-import           Reanimate.Signal+import           Reanimate.Ease import           Reanimate.Transition import           Reanimate.Svg.Constructors 

@@ -0,0 +1,99 @@+{-# LANGUAGE RecordWildCards #-}+module Reanimate.ColorComponents where++import           Codec.Picture+import           Codec.Picture.Types+import           Data.Colour+import           Data.Colour.CIE+import           Data.Colour.CIE.Illuminant (d65)+import           Data.Colour.RGBSpace+import           Data.Colour.RGBSpace.HSV+import           Data.Colour.SRGB+import           Data.Fixed+import           Reanimate.Ease++data ColorComponents = ColorComponents+  { colorUnpack :: Colour Double -> (Double, Double, Double)+  , colorPack   :: Double -> Double -> Double -> Colour Double }++-- | > interpolate rgbComponents yellow blue+--+--   <<docs/gifs/doc_rgbComponents.gif>>+rgbComponents :: ColorComponents+rgbComponents = ColorComponents rgbUnpack sRGB+  where+    rgbUnpack :: Colour Double -> (Double, Double, Double)+    rgbUnpack c =+      case toSRGB c of+        RGB r g b -> (r,g,b)++-- | > interpolate hsvComponents yellow blue+--+--   <<docs/gifs/doc_hsvComponents.gif>>+hsvComponents :: ColorComponents+hsvComponents = ColorComponents unpack pack+  where+    unpack = hsvView.toSRGB+    pack a b c = uncurryRGB sRGB $ hsv a b c++-- | > interpolate labComponents yellow blue+--+--   <<docs/gifs/doc_labComponents.gif>>+labComponents :: ColorComponents+labComponents = ColorComponents unpack pack+  where+    unpack = cieLABView d65+    pack = cieLAB d65++-- | > interpolate xyzComponents yellow blue+--+--   <<docs/gifs/doc_xyzComponents.gif>>+xyzComponents :: ColorComponents+xyzComponents = ColorComponents cieXYZView cieXYZ++-- | > interpolate lchComponents yellow blue+--+--   <<docs/gifs/doc_lchComponents.gif>>+lchComponents :: ColorComponents+lchComponents = ColorComponents unpack pack+  where+    toDeg,toRad :: Double -> Double+    toRad deg = deg/180 * pi+    toDeg rad = rad/pi * 180+    unpack :: Colour Double -> (Double, Double, Double)+    unpack color =+      let (l,a,b) = cieLABView d65 color+          c = sqrt (a*a + b*b)+          h :: Double+          h = (toDeg(atan2 b a) + 360) `mod'` 360+          isZero = round (c*10000) == (0::Integer)+      in (l, c, if isZero then 0/0 else h)+    pack l c h =+      cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c)++interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double)+interpolate ColorComponents{..} from to = \d ->+    colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d)+  where+    (a1,b1,c1) = colorUnpack from+    (a2,b2,c2) = colorUnpack to++interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8)+interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to)++interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8)+interpolateRGBA8 comps from to = \t ->+  case interp t of+    PixelRGB8 r g b ->+      let alpha = fromToS (fromIntegral $ pixelOpacity from) (fromIntegral $ pixelOpacity to) t+      in PixelRGBA8 r g b (round alpha)+  where+    interp = interpolateRGB8 comps (dropTransparency from) (dropTransparency to)++toRGB8 :: Colour Double -> PixelRGB8+toRGB8 c = PixelRGB8 r g b+  where+    RGB r g b = toSRGBBounded c++fromRGB8 :: PixelRGB8 -> Colour Double+fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b

@@ -0,0 +1,107 @@+module Reanimate.Ease+  ( Signal+  , constantS+  , fromToS+  , reverseS+  , curveS+  , powerS+  , bellS+  , oscillateS+  , fromListS+  , cubicBezierS+  ) where++-- | Signals are time-varying variables. Signals can be composed using function+--   composition.+type Signal = Double -> Double++fromListS :: [(Double, Signal)] -> Signal+fromListS fns t = worker 0 fns+  where+    worker _ [] = 0+    worker now [(len, fn)] = fn (min 1 ((t-now) / min (1-now) len))+    worker now ((len, fn):rest)+      | now+len < t = worker (now+len) rest+      | otherwise = fn ((t-now) / len)++-- | Constant signal.+--+--   Example:+--+--   > signalA (constantS 0.5) drawProgress+--+--   <<docs/gifs/doc_constantS.gif>>+constantS :: Double -> Signal+constantS = const++-- | Signal with new starting and end values.+--+--   Example:+--+--   > signalA (fromToS 0.8 0.2) drawProgress+--+--   <<docs/gifs/doc_fromToS.gif>>+fromToS :: Double -> Double -> Signal+fromToS from to t = from + (to-from)*t++-- | Reverse signal order.+--+--   Example:+--+--   > signalA reverseS drawProgress+--+--   <<docs/gifs/doc_reverseS.gif>>+reverseS :: Signal+reverseS t = 1-t++-- | S-curve signal. Takes a steepness parameter. 2 is a good default.+--+--   Example:+--+--   > signalA (curveS 2) drawProgress+--+--   <<docs/gifs/doc_curveS.gif>>+curveS :: Double -> Signal+curveS steepness s =+  if s < 0.5+    then 0.5 * (2*s)**steepness+    else 1-0.5 * (2 - 2*s)**steepness++powerS :: Double -> Signal+powerS steepness s = s**steepness++-- | Oscillate signal.+--+--   Example:+--+--   > signalA oscillateS drawProgress+--+--   <<docs/gifs/doc_oscillateS.gif>>+oscillateS :: Signal+oscillateS t =+  if t < 1/2+    then t*2+    else 2-t*2++-- | Bell-curve signal. Takes a steepness parameter. 2 is a good default.+--+--   Example:+--+--   > signalA (bellS 2) drawProgress+--+--   <<docs/gifs/doc_bellS.gif>>+bellS :: Double -> Signal+bellS steepness = curveS steepness . oscillateS++-- | Cubic Bezier signal. Gives you a fair amount of control over how the+--   signal will 'curve'.+--+--   Example:+--+--   > signalA (cubicBezierS (0.0, 0.8, 0.9, 1.0)) drawProgress+--   +--   <<docs/gifs/doc_cubicBezierS.gif>>+cubicBezierS :: (Double, Double, Double, Double) -> Signal+cubicBezierS (x1, x2, x3, x4) s = +  let ms = 1-s+  in x1*ms^(3::Int) + 3*x2*ms^(2::Int)*s + 3*x3*ms*s^(2::Int) + x4*s^(3::Int)

@@ -1,99 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module Reanimate.Interpolate where--import           Codec.Picture-import           Codec.Picture.Types-import           Data.Colour-import           Data.Colour.CIE-import           Data.Colour.CIE.Illuminant (d65)-import           Data.Colour.RGBSpace-import           Data.Colour.RGBSpace.HSV-import           Data.Colour.SRGB-import           Data.Fixed-import           Reanimate.Signal--data ColorComponents = ColorComponents-  { colorUnpack :: Colour Double -> (Double, Double, Double)-  , colorPack   :: Double -> Double -> Double -> Colour Double }---- | > interpolate rgbComponents yellow blue------   <<docs/gifs/doc_rgbComponents.gif>>-rgbComponents :: ColorComponents-rgbComponents = ColorComponents rgbUnpack sRGB-  where-    rgbUnpack :: Colour Double -> (Double, Double, Double)-    rgbUnpack c =-      case toSRGB c of-        RGB r g b -> (r,g,b)---- | > interpolate hsvComponents yellow blue------   <<docs/gifs/doc_hsvComponents.gif>>-hsvComponents :: ColorComponents-hsvComponents = ColorComponents unpack pack-  where-    unpack = hsvView.toSRGB-    pack a b c = uncurryRGB sRGB $ hsv a b c---- | > interpolate labComponents yellow blue------   <<docs/gifs/doc_labComponents.gif>>-labComponents :: ColorComponents-labComponents = ColorComponents unpack pack-  where-    unpack = cieLABView d65-    pack = cieLAB d65---- | > interpolate xyzComponents yellow blue------   <<docs/gifs/doc_xyzComponents.gif>>-xyzComponents :: ColorComponents-xyzComponents = ColorComponents cieXYZView cieXYZ---- | > interpolate lchComponents yellow blue------   <<docs/gifs/doc_lchComponents.gif>>-lchComponents :: ColorComponents-lchComponents = ColorComponents unpack pack-  where-    toDeg,toRad :: Double -> Double-    toRad deg = deg/180 * pi-    toDeg rad = rad/pi * 180-    unpack :: Colour Double -> (Double, Double, Double)-    unpack color =-      let (l,a,b) = cieLABView d65 color-          c = sqrt (a*a + b*b)-          h :: Double-          h = (toDeg(atan2 b a) + 360) `mod'` 360-          isZero = round (c*10000) == (0::Integer)-      in (l, c, if isZero then 0/0 else h)-    pack l c h =-      cieLAB d65 l (cos (toRad h) * c) (sin (toRad h) * c)--interpolate :: ColorComponents -> Colour Double -> Colour Double -> (Double -> Colour Double)-interpolate ColorComponents{..} from to = \d ->-    colorPack (a1 + (a2-a1)*d) (b1 + (b2-b1)*d) (c1 + (c2-c1)*d)-  where-    (a1,b1,c1) = colorUnpack from-    (a2,b2,c2) = colorUnpack to--interpolateRGB8 :: ColorComponents -> PixelRGB8 -> PixelRGB8 -> (Double -> PixelRGB8)-interpolateRGB8 comps from to = toRGB8 . interpolate comps (fromRGB8 from) (fromRGB8 to)--interpolateRGBA8 :: ColorComponents -> PixelRGBA8 -> PixelRGBA8 -> (Double -> PixelRGBA8)-interpolateRGBA8 comps from to = \t ->-  case interp t of-    PixelRGB8 r g b ->-      let alpha = fromToS (fromIntegral $ pixelOpacity from) (fromIntegral $ pixelOpacity to) t-      in PixelRGBA8 r g b (round alpha)-  where-    interp = interpolateRGB8 comps (dropTransparency from) (dropTransparency to)--toRGB8 :: Colour Double -> PixelRGB8-toRGB8 c = PixelRGB8 r g b-  where-    RGB r g b = toSRGBBounded c--fromRGB8 :: PixelRGB8 -> Colour Double-fromRGB8 (PixelRGB8 r g b) = sRGB24 r g b

@@ -1,18 +1,29 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}-module Reanimate.LaTeX (latex,xelatex,latexAlign) where+module Reanimate.LaTeX+  ( latex+  , latexChunks+  , xelatex+  , latexAlign+  )+where -import qualified Data.ByteString   as B-import           Data.Text         (Text)-import qualified Data.Text         as T-import qualified Data.Text.IO      as T-import           Graphics.SvgTree  (Tree (..), parseSvgFile)+import qualified Data.ByteString               as B+import           Data.Text                                ( Text )+import qualified Data.Text                     as T+import qualified Data.Text.IO                  as T+import           Graphics.SvgTree                         ( Tree(..)+                                                          , parseSvgFile+                                                          ) import           Reanimate.Cache import           Reanimate.Misc import           Reanimate.Svg import           Reanimate.Parameters-import           System.FilePath   (replaceExtension, takeFileName, (</>))-import           System.IO.Unsafe  (unsafePerformIO)+import           System.FilePath                          ( replaceExtension+                                                          , takeFileName+                                                          , (</>)+                                                          )+import           System.IO.Unsafe                         ( unsafePerformIO )  -- | Invoke latex and import the result as an SVG object. SVG objects are --   cached to improve performance.@@ -24,12 +35,25 @@ --   <<docs/gifs/doc_latex.gif>> latex :: T.Text -> Tree latex tex | pNoExternals = mkText tex-latex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG "dvi" exec args)) script-  where-    exec = "latex"-    args = []-    script = mkTexScript exec args [] tex+latex tex =+  (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG "dvi" exec args))+    script+ where+  exec   = "latex"+  args   = []+  script = mkTexScript exec args [] tex +latexChunks :: [T.Text] -> [Tree]+latexChunks chunks | pNoExternals = map mkText chunks+latexChunks chunks                = worker (svgGlyphs $ latex $ T.concat chunks) chunks+ where+  merge lst = mkGroup [ fmt svg | (fmt, _, svg) <- lst ]+  worker [] [] = []+  worker _ [] = error "latex chunk mismatch"+  worker everything (x : xs) =+    let width = length $ svgGlyphs (latex x)+    in merge (take width everything) : worker (drop width everything) xs+ -- | Invoke xelatex and import the result as an SVG object. SVG objects are --   cached to improve performance. Xelatex has support for non-western scripts. --@@ -40,12 +64,14 @@ --   <<docs/gifs/doc_xelatex.gif>> xelatex :: Text -> Tree xelatex tex | pNoExternals = mkText tex-xelatex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG "xdv" exec args)) script-  where-    exec = "xelatex"-    args = ["-no-pdf"]-    headers = ["\\usepackage[UTF8]{ctex}"]-    script = mkTexScript exec args headers tex+xelatex tex =+  (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG "xdv" exec args))+    script+ where+  exec    = "xelatex"+  args    = ["-no-pdf"]+  headers = ["\\usepackage[UTF8]{ctex}"]+  script  = mkTexScript exec args headers tex  -- | Invoke latex and import the result as an SVG object. SVG objects are --   cached to improve performance. This wraps the TeX code in an 'align*'@@ -60,39 +86,58 @@ latexAlign tex = latex $ T.unlines ["\\begin{align*}", tex, "\\end{align*}"]  postprocess :: Tree -> Tree-postprocess = lowerTransformations . scaleXY 1 (-1) . scale 0.1 . pathify+postprocess = simplify  -- executable, arguments, header, tex latexToSVG :: String -> String -> [String] -> Text -> IO Tree latexToSVG dviExt latexExec latexArgs tex = do   latexBin <- requireExecutable latexExec-  dvisvgm <- requireExecutable "dvisvgm"-  withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file -> withTempFile "svg" $ \svg_file -> do-    let dvi_file = tmp_dir </> replaceExtension (takeFileName tex_file) dviExt-    T.writeFile tex_file tex-    runCmd latexBin (latexArgs ++ ["-interaction=nonstopmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file])-    runCmd dvisvgm [ dvi_file, "--precision=5"-                   , "--exact"    -- better bboxes.-                   -- , "--bbox=1,1" -- increase bbox size.-                   , "--no-fonts" -- use glyphs instead of fonts.-                   ,"--verbosity=0", "-o",svg_file]-    svg_data <- B.readFile svg_file-    case parseSvgFile svg_file svg_data of-      Nothing  -> error "Malformed svg"-      Just svg -> return $ postprocess $ unbox $ replaceUses svg+  dvisvgm  <- requireExecutable "dvisvgm"+  withTempDir $ \tmp_dir -> withTempFile "tex" $ \tex_file ->+    withTempFile "svg" $ \svg_file -> do+      let dvi_file =+            tmp_dir </> replaceExtension (takeFileName tex_file) dviExt+      T.writeFile tex_file tex+      runCmd+        latexBin+        (  latexArgs+        ++ [ "-interaction=nonstopmode"+           , "-halt-on-error"+           , "-output-directory=" ++ tmp_dir+           , tex_file+           ]+        )+      runCmd+        dvisvgm+        [ dvi_file+        , "--precision=5"+        , "--exact"    -- better bboxes.+        , "--no-fonts" -- use glyphs instead of fonts.+        , "--scale=0.1,-0.1"+        , "--verbosity=0"+        , "-o"+        , svg_file+        ]+      svg_data <- B.readFile svg_file+      case parseSvgFile svg_file svg_data of+        Nothing  -> error "Malformed svg"+        Just svg -> return $ postprocess $ unbox $ replaceUses svg  mkTexScript :: String -> [String] -> [Text] -> Text -> Text-mkTexScript latexExec latexArgs texHeaders tex = T.unlines $-  [ "% " <> T.pack (unwords (latexExec:latexArgs))-  , "\\documentclass[preview]{standalone}"-  , "\\usepackage{amsmath}"-  , "\\usepackage{gensymb}"-  ] ++ texHeaders ++-  [ "\\usepackage[english]{babel}"-  , "\\linespread{1}"-  , "\\begin{document}"-  , tex-  , "\\end{document}" ]+mkTexScript latexExec latexArgs texHeaders tex =+  T.unlines+    $  [ "% " <> T.pack (unwords (latexExec : latexArgs))+       , "\\documentclass[preview]{standalone}"+       , "\\usepackage{amsmath}"+       , "\\usepackage{gensymb}"+       ]+    ++ texHeaders+    ++ [ "\\usepackage[english]{babel}"+       , "\\linespread{1}"+       , "\\begin{document}"+       , tex+       , "\\end{document}"+       ]  {- Packages used by manim. 

@@ -24,14 +24,14 @@                                          strokeOpacity) import           Linear.V2 import           Reanimate.Animation-import           Reanimate.Interpolate+import           Reanimate.ColorComponents import           Reanimate.Math.EarClip import           Reanimate.Math.Polygon (Polygon, mkPolygon, pAddPoints,                                          pCentroid, pRing, pSize, pdualPolygons,                                          polygonPoints) import           Reanimate.Math.SSSP import           Reanimate.PolyShape-import           Reanimate.Signal+import           Reanimate.Ease import           Reanimate.Svg  -- Correspondence

@@ -8,7 +8,7 @@ import           Data.Hashable import qualified Data.Vector            as V import           Linear.Vector-import           Reanimate.Interpolate+import           Reanimate.ColorComponents import           Reanimate.Math.Common import           Reanimate.Math.Polygon import           Reanimate.Morph.Cache

@@ -8,7 +8,7 @@ import           Linear.V2 import           Linear.Metric -import           Reanimate.Signal+import           Reanimate.Ease import           Reanimate.Morph.Common import           Reanimate.Math.Polygon 

@@ -1,107 +0,0 @@-module Reanimate.Signal-  ( Signal-  , constantS-  , fromToS-  , reverseS-  , curveS-  , powerS-  , bellS-  , oscillateS-  , fromListS-  , cubicBezierS-  ) where---- | Signals are time-varying variables. Signals can be composed using function---   composition.-type Signal = Double -> Double--fromListS :: [(Double, Signal)] -> Signal-fromListS fns t = worker 0 fns-  where-    worker _ [] = 0-    worker now [(len, fn)] = fn (min 1 ((t-now) / min (1-now) len))-    worker now ((len, fn):rest)-      | now+len < t = worker (now+len) rest-      | otherwise = fn ((t-now) / len)---- | Constant signal.------   Example:------   > signalA (constantS 0.5) drawProgress------   <<docs/gifs/doc_constantS.gif>>-constantS :: Double -> Signal-constantS = const---- | Signal with new starting and end values.------   Example:------   > signalA (fromToS 0.8 0.2) drawProgress------   <<docs/gifs/doc_fromToS.gif>>-fromToS :: Double -> Double -> Signal-fromToS from to t = from + (to-from)*t---- | Reverse signal order.------   Example:------   > signalA reverseS drawProgress------   <<docs/gifs/doc_reverseS.gif>>-reverseS :: Signal-reverseS t = 1-t---- | S-curve signal. Takes a steepness parameter. 2 is a good default.------   Example:------   > signalA (curveS 2) drawProgress------   <<docs/gifs/doc_curveS.gif>>-curveS :: Double -> Signal-curveS steepness s =-  if s < 0.5-    then 0.5 * (2*s)**steepness-    else 1-0.5 * (2 - 2*s)**steepness--powerS :: Double -> Signal-powerS steepness s = s**steepness---- | Oscillate signal.------   Example:------   > signalA oscillateS drawProgress------   <<docs/gifs/doc_oscillateS.gif>>-oscillateS :: Signal-oscillateS t =-  if t < 1/2-    then t*2-    else 2-t*2---- | Bell-curve signal. Takes a steepness parameter. 2 is a good default.------   Example:------   > signalA (bellS 2) drawProgress------   <<docs/gifs/doc_bellS.gif>>-bellS :: Double -> Signal-bellS steepness = curveS steepness . oscillateS---- | Cubic Bezier signal. Gives you a fair amount of control over how the---   signal will 'curve'.------   Example:------   > signalA (cubicBezierS (0.0, 0.8, 0.9, 1.0)) drawProgress---   ---   <<docs/gifs/doc_cubicBezierS.gif>>-cubicBezierS :: (Double, Double, Double, Double) -> Signal-cubicBezierS (x1, x2, x3, x4) s = -  let ms = 1-s-  in x1*ms^(3::Int) + 3*x2*ms^(2::Int)*s + 3*x3*ms*s^(2::Int) + x4*s^(3::Int)

@@ -174,6 +174,7 @@   where     worker acc attr =       \case+        None -> []         GroupTree g ->           let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])               attr' = (g^.drawAttributes) `mappend` attr

@@ -37,12 +37,12 @@         Nothing  -> m         Just tid -> Map.insert tid tree m +-- FIXME: the viewbox is ignored. Can we use the viewbox as a mask? -- Transform out viewbox. defs and CSS rules are discarded. unbox :: Document -> Tree-unbox doc@Document{_viewBox = Just (minx, minw, _width, _height)} =+unbox doc@Document{_viewBox = Just (_minx, _minw, _width, _height)} =   GroupTree $ defaultSvg           & groupChildren .~ doc^.elements-          & transform ?~ [Translate (-minx) (-minw)] unbox doc =   GroupTree $ defaultSvg     & groupChildren .~ doc^.elements

@@ -9,7 +9,7 @@   ) where  import Reanimate.Animation-import Reanimate.Signal+import Reanimate.Ease import Reanimate.Effect  -- | A transition transforms one animation into another.

@@ -0,0 +1,274 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE RecordWildCards #-}+{-|+  Reanimate can automatically synchronize animations to your voice if you have+  a transcript and an audio recording. This works with the help of Gentle+  (<https://lowerquality.com/gentle/>). Accuracy is not perfect but it is pretty+  close, and it is by far the easiest way of adding narration to an animation.+-}+module Reanimate.Voice+  ( Transcript(..)+  , TWord(..)+  , findWord        -- :: Transcript -> [Text] -> Text -> TWord+  , findWords       -- :: Transcript -> [Text] -> Text -> [TWord]+  , loadTranscript  -- :: FilePath -> Transcript+  , fakeTranscript  -- :: Text -> Transcript+  , splitTranscript -- :: Transcript -> SVG -> [(SVG, TWord)]+  )+where++import           Data.Aeson+import           Data.Char+import           System.IO.Unsafe                         ( unsafePerformIO )+import           System.Directory+import           System.FilePath+import           System.Process+import           System.Exit+import           Data.List+import           Data.Maybe+import qualified Data.Map                      as Map+import           Data.Map                                 ( Map )+import           Data.Text                                ( Text )+import qualified Data.Text                     as T+import qualified Data.Text.IO                  as T+import           Reanimate.Animation                      ( SVG )+import           Reanimate.Misc+import           Reanimate.LaTeX++data Transcript = Transcript+  { transcriptText  :: Text+  , transcriptKeys  :: Map Text Int+  , transcriptWords :: [TWord]+  } deriving (Show)++instance FromJSON Transcript where+  parseJSON = withObject "transcript" $ \o ->+    Transcript <$> o .: "transcript" <*> pure Map.empty <*> o .: "words"++data TWord = TWord+  { wordAligned     :: Text+  , wordCase        :: Text+  , wordStart       :: Double -- ^ Start of pronunciation in seconds+  , wordStartOffset :: Int    -- ^ Character index of word in transcript+  , wordEnd         :: Double -- ^ End of pronunciation in seconds+  , wordEndOffset   :: Int    -- ^ Last character index of word in transcript+  , wordPhones      :: [Phone]+  , wordReference   :: Text   -- ^ The word being pronounced.+  } deriving (Show)++instance FromJSON TWord where+  parseJSON = withObject "word" $ \o ->+    TWord+      <$> o+      .:? "alignedWord"+      .!= T.empty+      <*> o+      .:  "case"+      <*> o+      .:? "start"+      .!= 0+      <*> o+      .:  "startOffset"+      <*> o+      .:? "end"+      .!= 0+      <*> o+      .:  "endOffset"+      <*> o+      .:? "phones"+      .!= []+      <*> o+      .:  "word"++data Phone = Phone+  { phoneDuration :: Double+  , phoneType     :: Text+  } deriving (Show)++instance FromJSON Phone where+  parseJSON =+    withObject "phone" $ \o -> Phone <$> o .: "duration" <*> o .: "phone"++-- | Locate the first word that occurs after all the given keys.+--   An error is thrown if no such word exists. An error is thrown+--   if the keys do not exist in the transcript.+findWord :: Transcript -> [Text] -> Text -> TWord+findWord t keys w = case listToMaybe (findWords t keys w) of+  Nothing    -> error $ "Word not in transcript: " ++ show (keys, w)+  Just tword -> tword++-- | Locate all words that occur after all the given keys.+--   May return an empty list. An error is thrown+--   if the keys do not exist in the transcript.+findWords :: Transcript -> [Text] -> Text -> [TWord]+findWords t [] wd =+  [ tword | tword <- transcriptWords t, wordReference tword == wd ]+findWords t (key : keys) wd =+  [ tword+  | tword <- findWords t keys wd+  , wordStartOffset tword > Map.findWithDefault badKey key (transcriptKeys t)+  ]+  where badKey = error $ "Missing transcript key: " ++ show key++-- | Loading a transcript does three things depending on which files are available+--   with the same basename as the input argument:+--   1. If a JSON file is available, it is parsed and returned.+--   2. If an audio file is available, reanimate tries to align it by calling out to+--      Gentle on localhost:8765/. If Gentle is not running, an error will be thrown.+--   3. If only the text transcript is available, a fake transcript is returned,+--      with timings roughly at 120 words per minute.+loadTranscript :: FilePath -> Transcript+loadTranscript path = unsafePerformIO $ do+  rawTranscript <- T.readFile path+  let keys           = parseTranscriptKeys rawTranscript+      trimTranscript = cutoutKeys keys rawTranscript+  hasJSON    <- doesFileExist jsonPath+  transcript <- if hasJSON+    then do+      mbT <- decodeFileStrict jsonPath+      case mbT of+        Nothing -> error "bad json"+        Just t  -> pure t+    else do+      hasAudio <- findWithExtension path audioExtensions+      case hasAudio of+        Nothing        -> return $ fakeTranscript' trimTranscript+        Just audioPath -> withTempFile "txt" $ \txtPath -> do+          T.writeFile txtPath trimTranscript+          runGentleForcedAligner audioPath txtPath+          mbT <- decodeFileStrict jsonPath+          case mbT of+            Nothing -> error "bad json"+            Just t  -> pure t+  pure $ transcript { transcriptKeys = keys }+ where+  jsonPath        = replaceExtension path "json"+  audioExtensions = ["mp3", "m4a", "flac"]++parseTranscriptKeys :: Text -> Map Text Int+parseTranscriptKeys = worker Map.empty 0+ where+  worker keys offset txt = case T.uncons txt of+    Nothing -> keys+    Just ('[', cs) ->+      let key       = T.takeWhile (/= ']') cs+          newOffset = T.length key + 2+      in  worker (Map.insert key offset keys)+                 (offset + newOffset)+                 (T.drop newOffset txt)+    Just (_, cs) -> worker keys (offset + 1) cs++cutoutKeys :: Map Text Int -> Text -> Text+cutoutKeys keys = T.concat . worker 0 (sortOn snd (Map.toList keys))+ where+  worker _offset [] txt = [txt]+  worker offset ((key, at) : xs) txt =+    let keyLen          = T.length key + 2+        (before, after) = T.splitAt (at - offset) txt+    in  before : worker (at + keyLen) xs (T.drop keyLen after)++findWithExtension :: FilePath -> [String] -> IO (Maybe FilePath)+findWithExtension _path []       = return Nothing+findWithExtension path  (e : es) = do+  let newPath = replaceExtension path e+  hasFile <- doesFileExist newPath+  if hasFile then return (Just newPath) else findWithExtension path es++runGentleForcedAligner :: FilePath -> FilePath -> IO ()+runGentleForcedAligner audioFile transcriptFile = do+  ret <- rawSystem prog args+  case ret of+    ExitSuccess -> return ()+    ExitFailure e ->+      error+        $  "Gentle forced aligner failed with: "+        ++ show e+        ++ "\nIs it running locally on port 8765?"+        ++ "\nCommand: "+        ++ showCommandForUser prog args+ where+  prog = "curl"+  args =+    [ "--silent"+    , "--form"+    , "audio=@" ++ audioFile+    , "--form"+    , "transcript=@" ++ transcriptFile+    , "--output"+    , replaceExtension audioFile "json"+    , "http://localhost:8765/transcriptions?async=false"+    ]++data Token = TokenWord Int Int Text | TokenComma | TokenPeriod | TokenParagraph+  deriving (Show)++lexText :: Text -> [Token]+lexText = worker 0+ where+  worker offset txt = case T.uncons txt of+    Nothing -> []+    Just (c, cs)+      | isSpace c+      -> let (w, rest) = T.span (== '\n') txt+         in  if T.length w >= 3+               then TokenParagraph : worker (offset + T.length w) rest+               else worker (offset + 1) cs+      | c == '.'+      -> TokenPeriod : worker (offset + 1) cs+      | c == ','+      -> TokenComma : worker (offset + 1) cs+      | isAlphaNum c+      -> let (w, rest) = T.span (\elt -> isAlphaNum elt || elt == '\'') txt+             newOffset = offset + T.length w+         in  TokenWord offset newOffset w : worker newOffset rest+      | otherwise+      -> worker (offset + 1) cs++-- | Fake transcript timings at roughly 120 words per minute.+fakeTranscript :: Text -> Transcript+fakeTranscript rawTranscript =+  let keys = parseTranscriptKeys rawTranscript+      t    = fakeTranscript' (cutoutKeys keys rawTranscript)+  in  t { transcriptKeys = keys }++fakeTranscript' :: Text -> Transcript+fakeTranscript' input = Transcript { transcriptText  = input+                                   , transcriptKeys  = Map.empty+                                   , transcriptWords = worker 0 (lexText input)+                                   }+ where+  worker _now []             = []+  worker now  (token : rest) = case token of+    TokenWord start end w ->+      let duration = realToFrac (end - start) * 0.1+      in  TWord { wordAligned     = T.toLower w+                , wordCase        = "success"+                , wordStart       = now+                , wordStartOffset = start+                , wordEnd         = now + duration+                , wordEndOffset   = end+                , wordPhones      = []+                , wordReference   = w+                }+            : worker (now + duration) rest+    TokenComma     -> worker (now + commaPause) rest+    TokenPeriod    -> worker (now + periodPause) rest+    TokenParagraph -> worker (now + paragraphPause) rest+  paragraphPause = 0.5+  commaPause     = 0.1+  periodPause    = 0.2++-- | Convert the transcript text to an SVG image using LaTeX and associate+--   each word image with its timing information.+splitTranscript :: Transcript -> [(SVG, TWord)]+splitTranscript Transcript {..} =+  [ (svg, tword)+  | tword@TWord {..} <- transcriptWords+  , let wordLength  = wordEndOffset - wordStartOffset+        [_, svg, _] = latexChunks+          [ T.take wordStartOffset transcriptText+          , T.take wordLength (T.drop wordStartOffset transcriptText)+          , T.drop wordEndOffset transcriptText+          ]+  ]