summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavidHimmelstrup <>2020-05-22 15:33:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-05-22 15:33:00 (GMT)
commit38a38cc9b74154dd3df6bb594132d600a2c8cb0f (patch)
treea9dd4cb57af5e1e167d848928d9db97d9da917f6
parentd495ec250e737e01e36425b0d01fb1f371a0901c (diff)
version 0.3.3.0HEAD0.3.3.0master
-rw-r--r--docs/gifs/doc_identityS.gifbin0 -> 11373 bytes
-rw-r--r--docs/gifs/doc_signalFlat.gifbin0 -> 2528 bytes
-rw-r--r--docs/gifs/doc_signalT.gifbin0 -> 49019 bytes
-rwxr-xr-xexamples/demo_stars.hs77
-rwxr-xr-xexamples/doc_circlePlot.hs2
-rwxr-xr-xexamples/doc_hsvComponents.hs2
-rwxr-xr-xexamples/doc_labComponents.hs2
-rwxr-xr-xexamples/doc_lchComponents.hs2
-rwxr-xr-xexamples/doc_rgbComponents.hs2
-rwxr-xr-xexamples/doc_ternaryPlot.hs2
-rwxr-xr-xexamples/doc_xyzComponents.hs2
-rwxr-xr-xexamples/morphology_color.hs2
-rwxr-xr-xexamples/tangent_and_normal.hs2
-rwxr-xr-xexamples/tut_glue_fourier.hs2
-rwxr-xr-xexamples/tut_glue_physics.hs2
-rw-r--r--examples/voice_advanced.hs153
-rw-r--r--examples/voice_fake.hs56
-rw-r--r--examples/voice_transcript.hs221
-rw-r--r--examples/voice_triggers.hs67
-rw-r--r--reanimate.cabal9
-rw-r--r--src/Reanimate.hs4
-rw-r--r--src/Reanimate/Animation.hs2
-rw-r--r--src/Reanimate/Builtin/Flip.hs2
-rw-r--r--src/Reanimate/ColorComponents.hs (renamed from src/Reanimate/Interpolate.hs)4
-rw-r--r--src/Reanimate/Ease.hs (renamed from src/Reanimate/Signal.hs)2
-rw-r--r--src/Reanimate/LaTeX.hs135
-rw-r--r--src/Reanimate/Morph/Common.hs4
-rw-r--r--src/Reanimate/Morph/Linear.hs2
-rw-r--r--src/Reanimate/Morph/Rotational.hs2
-rw-r--r--src/Reanimate/Svg.hs1
-rw-r--r--src/Reanimate/Svg/Unuse.hs4
-rw-r--r--src/Reanimate/Transition.hs2
-rw-r--r--src/Reanimate/Voice.hs274
33 files changed, 776 insertions, 267 deletions
diff --git a/docs/gifs/doc_identityS.gif b/docs/gifs/doc_identityS.gif
new file mode 100644
index 0000000..2bb13fe
--- /dev/null
+++ b/docs/gifs/doc_identityS.gif
Binary files differ
diff --git a/docs/gifs/doc_signalFlat.gif b/docs/gifs/doc_signalFlat.gif
new file mode 100644
index 0000000..d458594
--- /dev/null
+++ b/docs/gifs/doc_signalFlat.gif
Binary files differ
diff --git a/docs/gifs/doc_signalT.gif b/docs/gifs/doc_signalT.gif
new file mode 100644
index 0000000..1e16d6e
--- /dev/null
+++ b/docs/gifs/doc_signalT.gif
Binary files differ
diff --git a/examples/demo_stars.hs b/examples/demo_stars.hs
new file mode 100755
index 0000000..8e168a0
--- /dev/null
+++ b/examples/demo_stars.hs
@@ -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
diff --git a/examples/doc_circlePlot.hs b/examples/doc_circlePlot.hs
index a97f846..36ec0b2 100755
--- a/examples/doc_circlePlot.hs
+++ b/examples/doc_circlePlot.hs
@@ -5,7 +5,7 @@ module Main(main) where
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
diff --git a/examples/doc_hsvComponents.hs b/examples/doc_hsvComponents.hs
index 3616603..da70753 100755
--- a/examples/doc_hsvComponents.hs
+++ b/examples/doc_hsvComponents.hs
@@ -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 ()
diff --git a/examples/doc_labComponents.hs b/examples/doc_labComponents.hs
index 71af8e9..aff016a 100755
--- a/examples/doc_labComponents.hs
+++ b/examples/doc_labComponents.hs
@@ -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 ()
diff --git a/examples/doc_lchComponents.hs b/examples/doc_lchComponents.hs
index c21b4b5..33c32a4 100755
--- a/examples/doc_lchComponents.hs
+++ b/examples/doc_lchComponents.hs
@@ -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 ()
diff --git a/examples/doc_rgbComponents.hs b/examples/doc_rgbComponents.hs
index 59c70fd..c27cb97 100755
--- a/examples/doc_rgbComponents.hs
+++ b/examples/doc_rgbComponents.hs
@@ -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 ()
diff --git a/examples/doc_ternaryPlot.hs b/examples/doc_ternaryPlot.hs
index 638c685..e038685 100755
--- a/examples/doc_ternaryPlot.hs
+++ b/examples/doc_ternaryPlot.hs
@@ -5,7 +5,7 @@ module Main(main) where
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
diff --git a/examples/doc_xyzComponents.hs b/examples/doc_xyzComponents.hs
index 5e4d4fe..76f75b1 100755
--- a/examples/doc_xyzComponents.hs
+++ b/examples/doc_xyzComponents.hs
@@ -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 ()
diff --git a/examples/morphology_color.hs b/examples/morphology_color.hs
index 6d8f101..b3966f5 100755
--- a/examples/morphology_color.hs
+++ b/examples/morphology_color.hs
@@ -6,7 +6,7 @@ module Main(main) where
import Codec.Picture
import Reanimate
-import Reanimate.Interpolate
+import Reanimate.ColorComponents
import Reanimate.Morph.Common
import Reanimate.Morph.Linear
diff --git a/examples/tangent_and_normal.hs b/examples/tangent_and_normal.hs
index 7bba77b..bd44a4f 100755
--- a/examples/tangent_and_normal.hs
+++ b/examples/tangent_and_normal.hs
@@ -14,7 +14,7 @@ import qualified Diagrams.Prelude as D
import Reanimate.Diagrams
import Reanimate.Driver (reanimate)
import Reanimate.Animation
-import Reanimate.Signal
+import Reanimate.Ease
import Reanimate.Svg
diff --git a/examples/tut_glue_fourier.hs b/examples/tut_glue_fourier.hs
index 0b4f15b..566e3d4 100755
--- a/examples/tut_glue_fourier.hs
+++ b/examples/tut_glue_fourier.hs
@@ -7,7 +7,7 @@ import Data.Complex
import Graphics.SvgTree
import Linear.V2
import Reanimate
-import Reanimate.Signal
+import Reanimate.Ease
import Codec.Picture
-- layer 3
diff --git a/examples/tut_glue_physics.hs b/examples/tut_glue_physics.hs
index e2a3def..fceac44 100755
--- a/examples/tut_glue_physics.hs
+++ b/examples/tut_glue_physics.hs
@@ -11,7 +11,7 @@ import Linear.V2 (V2 (..))
import Reanimate
import Reanimate.Chiphunk
import Reanimate.PolyShape
-import Reanimate.Signal
+import Reanimate.Ease
import System.IO.Unsafe (unsafePerformIO)
shatter :: Animation
diff --git a/examples/voice_advanced.hs b/examples/voice_advanced.hs
new file mode 100644
index 0000000..dc6fb4c
--- /dev/null
+++ b/examples/voice_advanced.hs
@@ -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
+ ]
diff --git a/examples/voice_fake.hs b/examples/voice_fake.hs
new file mode 100644
index 0000000..663ba22
--- /dev/null
+++ b/examples/voice_fake.hs
@@ -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
diff --git a/examples/voice_transcript.hs b/examples/voice_transcript.hs
index e6b8ef3..3481e81 100644
--- a/examples/voice_transcript.hs
+++ b/examples/voice_transcript.hs
@@ -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
+ where
+ wordKey tword =
+ T.unpack (wordReference tword) ++ show (wordStartOffset tword)
-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
-
-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
diff --git a/examples/voice_triggers.hs b/examples/voice_triggers.hs
new file mode 100644
index 0000000..0b42306
--- /dev/null
+++ b/examples/voice_triggers.hs
@@ -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
diff --git a/reanimate.cabal b/reanimate.cabal
index 5613ba8..d070bb0 100644
--- a/reanimate.cabal
+++ b/reanimate.cabal
@@ -3,7 +3,7 @@ cabal-version: 1.18
-- 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 @@ library
default-extensions: PackageImports
exposed-modules: Reanimate
Reanimate.Animation
- Reanimate.Signal
+ Reanimate.Ease
Reanimate.Render
Reanimate.LaTeX
Reanimate.Svg
@@ -80,9 +80,9 @@ library
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 @@ library
Reanimate.GeoProjection
Reanimate.Builtin.Documentation
Reanimate.Builtin.Images
+ Reanimate.Voice
other-modules: Reanimate.Cache
Reanimate.Driver
Reanimate.Driver.Check
@@ -111,7 +112,7 @@ library
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,
diff --git a/src/Reanimate.hs b/src/Reanimate.hs
index a4bdb87..f25cd2f 100644
--- a/src/Reanimate.hs
+++ b/src/Reanimate.hs
@@ -63,7 +63,7 @@ module Reanimate
freezeAtPercentage,
addStatic,
signalA,
- -- ** Signals
+ -- ** Easing functions
Signal,
constantS,
fromToS,
@@ -197,7 +197,7 @@ import Reanimate.Povray
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
diff --git a/src/Reanimate/Animation.hs b/src/Reanimate/Animation.hs
index 8d2caac..7d76b8b 100644
--- a/src/Reanimate/Animation.hs
+++ b/src/Reanimate/Animation.hs
@@ -51,7 +51,7 @@ import Graphics.SvgTree (Alignment (..), Document (..),
Tree (..), xmlOfTree)
import Graphics.SvgTree.Printer
import Reanimate.Constants
-import Reanimate.Signal
+import Reanimate.Ease
import Reanimate.Svg.Constructors
import Text.XML.Light.Output
diff --git a/src/Reanimate/Builtin/Flip.hs b/src/Reanimate/Builtin/Flip.hs
index 7855784..0dcf002 100644
--- a/src/Reanimate/Builtin/Flip.hs
+++ b/src/Reanimate/Builtin/Flip.hs
@@ -14,7 +14,7 @@ import Reanimate.Animation
import Reanimate.Blender
import Reanimate.Raster
import Reanimate.Scene
-import Reanimate.Signal
+import Reanimate.Ease
import Reanimate.Transition
import Reanimate.Svg.Constructors
diff --git a/src/Reanimate/Interpolate.hs b/src/Reanimate/ColorComponents.hs
index 058a943..333f356 100644
--- a/src/Reanimate/Interpolate.hs
+++ b/src/Reanimate/ColorComponents.hs
@@ -1,5 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
-module Reanimate.Interpolate where
+module Reanimate.ColorComponents where
import Codec.Picture
import Codec.Picture.Types
@@ -10,7 +10,7 @@ import Data.Colour.RGBSpace
import Data.Colour.RGBSpace.HSV
import Data.Colour.SRGB
import Data.Fixed
-import Reanimate.Signal
+import Reanimate.Ease
data ColorComponents = ColorComponents
{ colorUnpack :: Colour Double -> (Double, Double, Double)
diff --git a/src/Reanimate/Signal.hs b/src/Reanimate/Ease.hs
index 92c5919..e12598a 100644
--- a/src/Reanimate/Signal.hs
+++ b/src/Reanimate/Ease.hs
@@ -1,4 +1,4 @@
-module Reanimate.Signal
+module Reanimate.Ease
( Signal
, constantS
, fromToS
diff --git a/src/Reanimate/LaTeX.hs b/src/Reanimate/LaTeX.hs
index fadb5f1..2379336 100644
--- a/src/Reanimate/LaTeX.hs
+++ b/src/Reanimate/LaTeX.hs
@@ -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,11 +35,24 @@ import System.IO.Unsafe (unsafePerformIO)
-- <<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 @@ latex tex = (unsafePerformIO . (cacheMem . cacheDiskSvg) (latexToSVG "dvi" exec
-- <<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 :: Text -> Tree
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.
diff --git a/src/Reanimate/Morph/Common.hs b/src/Reanimate/Morph/Common.hs
index 4c9f94f..ae11b2d 100644
--- a/src/Reanimate/Morph/Common.hs
+++ b/src/Reanimate/Morph/Common.hs
@@ -24,14 +24,14 @@ import Graphics.SvgTree (DrawAttributes, Texture (..),
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
diff --git a/src/Reanimate/Morph/Linear.hs b/src/Reanimate/Morph/Linear.hs
index 8bcca28..6c9a6cb 100644
--- a/src/Reanimate/Morph/Linear.hs
+++ b/src/Reanimate/Morph/Linear.hs
@@ -8,7 +8,7 @@ module Reanimate.Morph.Linear
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
diff --git a/src/Reanimate/Morph/Rotational.hs b/src/Reanimate/Morph/Rotational.hs
index 25c2ae7..5f45b09 100644
--- a/src/Reanimate/Morph/Rotational.hs
+++ b/src/Reanimate/Morph/Rotational.hs
@@ -8,7 +8,7 @@ import Linear.Vector
import Linear.V2
import Linear.Metric
-import Reanimate.Signal
+import Reanimate.Ease
import Reanimate.Morph.Common
import Reanimate.Math.Polygon
diff --git a/src/Reanimate/Svg.hs b/src/Reanimate/Svg.hs
index a4d7c25..f465e1c 100644
--- a/src/Reanimate/Svg.hs
+++ b/src/Reanimate/Svg.hs
@@ -174,6 +174,7 @@ svgGlyphs = worker id defaultSvg
where
worker acc attr =
\case
+ None -> []
GroupTree g ->
let acc' sub = acc (GroupTree $ g & groupChildren .~ [sub])
attr' = (g^.drawAttributes) `mappend` attr
diff --git a/src/Reanimate/Svg/Unuse.hs b/src/Reanimate/Svg/Unuse.hs
index f3e8ea8..756a155 100644
--- a/src/Reanimate/Svg/Unuse.hs
+++ b/src/Reanimate/Svg/Unuse.hs
@@ -37,12 +37,12 @@ replaceUses doc = doc & elements %~ map (mapTree replace)
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
diff --git a/src/Reanimate/Transition.hs b/src/Reanimate/Transition.hs
index 850116f..05cf3a7 100644
--- a/src/Reanimate/Transition.hs
+++ b/src/Reanimate/Transition.hs
@@ -9,7 +9,7 @@ module Reanimate.Transition
) where
import Reanimate.Animation
-import Reanimate.Signal
+import Reanimate.Ease
import Reanimate.Effect
-- | A transition transforms one animation into another.
diff --git a/src/Reanimate/Voice.hs b/src/Reanimate/Voice.hs
new file mode 100644
index 0000000..57b0812
--- /dev/null
+++ b/src/Reanimate/Voice.hs
@@ -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
+ ]
+ ]