reanimate-0.3.2.1: examples/voice_transcript.hs

#!/usr/bin/env stack
-- 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

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

main :: IO ()
main = reanimate $ sceneAnimation $ do
  newSpriteSVG_ $ mkBackground "black"
  waitOn $ forM_ (transcriptGlyphs transcript) $ \(svg, tword) -> do
    highlighted <- newVar 0
    s <- 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
  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

maskedOut :: Double -> SVG -> SVG -> SVG
maskedOut 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, 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