reanimate-0.3.2.0: 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
  "Testing transcript.\n\n\
  \Second paragraph"

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 >= 2
           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 = 60 / wpm
      in  TWord { wordAligned     = T.toLower w
                , wordCase        = "success"
                , wordStart       = now
                , wordStartOffset = 0
                , wordEnd         = now + duration
                , wordEndOffset   = 0
                , 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.1
  commaPause     = 0.05
  periodPause    = 0.05

-- 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"
  let maskSVG =
        simplify $ withStrokeWidth 0 $ lowerTransformations $ center $ latex "Masked"
  -- newSpriteSVG $ maskSVG
  -- newSpriteA $ animate $ \t -> mkGroup
  --   [ maskedIn t maskSVG (withFillColor "blue" $ mkRect (svgWidth maskSVG) screenHeight)
  --   , maskedOut t maskSVG (withFillColor "white" $ mkRect (svgWidth maskSVG) screenHeight)
  --   ]
  newSpriteSVG $ withFillColor "grey" $ scale 0.8 $ center $ latex $ transcriptText
    transcript

  -- wait 10
  -- _ <- newSpriteSVG $ withStrokeWidth (defaultStrokeWidth*0.5) $
  --       withStrokeColor "white" $ mkLine (-screenWidth, 0) (screenWidth, 0)
  -- _ <- newSpriteSVG $ withStrokeWidth (defaultStrokeWidth*0.5) $
  --       withStrokeColor "white" $ mkLine (0, -screenHeight) (0,screenHeight)
  cOpacity <- newVar 0
  cFill    <- newVar $ toColor "black"
  let
    pushFill newColor = do
      prevColor <- readVar cFill
      tweenVar cFill 0.2
        $ \p t -> if t > 0
            then interpolateRGBA8 labComponents prevColor (toColor newColor) t
            else p
  c <- newSprite $ do
    o <- unVar cOpacity
    f <- unVar cFill
    pure
      $ withGroupOpacity o
      $ withStrokeColor "white"
      $ withFillColorPixel f
      $ translate 4 0
      $ mkCircle 1
  txtVar <- newVar (mkGroup [])
  t      <- newSprite $ do
    screenText <- unVar txtVar
    pure $ withFillColor "white" $ screenText
  -- waitOn $ forM_ (transcriptWords transcript) $ \TWord {..} ->
  --   fork $ when (wordCase == "success") $ do
  --     wait (wordStart - 0.1)
  --     when (wordReference == "circle") $ do
  --       wait (-0.1)
  --       tweenVar cOpacity 0.2 $ \v -> fromToS v 1
  --     when (wordReference == "red") $ pushFill "red"
  --     when (wordReference == "green") $ pushFill "green"
  --     when (wordReference == "blue") $ pushFill "blue"
  --     when (wordReference == "Cyan") $ pushFill "cyan"
  --     when (wordReference == "Purple") $ pushFill "purple"
  --     when (wordReference == "White") $ pushFill "white"
  --     writeVar txtVar $ alignText $ forceLayout wordReference
  wait 3
  return ()

maskedIn :: Double -> SVG -> SVG -> SVG
maskedIn t maskSVG targetSVG = mkGroup
  [ mkClipPath label $ removeGroups maskSVG
  , withClipPathRef (Ref label) $ translate (-svgWidth maskSVG * (1 - t)) 0 targetSVG
  ]
  where label = "word-mask-" ++ show (hash $ renderTree maskSVG)

maskedOut :: Double -> SVG -> SVG -> SVG
maskedOut t maskSVG targetSVG = mkGroup
  [ mkClipPath label $ removeGroups maskSVG
  , withClipPathRef (Ref label) $ translate (svgWidth maskSVG * t) 0 targetSVG
  ]
  where label = "word-mask-" ++ show (hash $ renderTree maskSVG)


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