Driver.hs

{-# LANGUAGE RecordWildCards #-}
module Reanimate.Driver
  ( reanimate
  )
where

import           Control.Applicative      ((<|>))
import           Control.Concurrent
import           Control.Monad
import           Data.Either
import           Data.Maybe
import           Reanimate.Animation      (Animation, duration)
import           Reanimate.Driver.CLI
import           Reanimate.Driver.Check
import           Reanimate.Driver.Daemon
import           Reanimate.Parameters
import           Reanimate.Render         (render, renderSnippets, renderSvgs, renderSvgs_,
                                           selectRaster)
import           System.Directory
import           System.Exit
import           System.FilePath
import           System.IO
import           Text.Printf

presetFormat :: Preset -> Format
presetFormat Youtube    = RenderMp4
presetFormat ExampleGif = RenderGif
presetFormat Quick      = RenderMp4
presetFormat MediumQ    = RenderMp4
presetFormat HighQ      = RenderMp4
presetFormat LowFPS     = RenderMp4

presetFPS :: Preset -> FPS
presetFPS Youtube    = 60
presetFPS ExampleGif = 25
presetFPS Quick      = 15
presetFPS MediumQ    = 30
presetFPS HighQ      = 30
presetFPS LowFPS     = 10

presetWidth :: Preset -> Width
presetWidth Youtube    = 2560
presetWidth ExampleGif = 320
presetWidth Quick      = 320
presetWidth MediumQ    = 800
presetWidth HighQ      = 1920
presetWidth LowFPS     = presetWidth HighQ

presetHeight :: Preset -> Height
presetHeight preset = presetWidth preset * 9 `div` 16

formatFPS :: Format -> FPS
formatFPS RenderMp4  = 60
formatFPS RenderGif  = 25
formatFPS RenderWebm = 60

formatWidth :: Format -> Width
formatWidth RenderMp4  = 2560
formatWidth RenderGif  = 320
formatWidth RenderWebm = 2560

formatHeight :: Format -> Height
formatHeight RenderMp4  = 1440
formatHeight RenderGif  = 180
formatHeight RenderWebm = 1440

formatExtension :: Format -> String
formatExtension RenderMp4  = "mp4"
formatExtension RenderGif  = "gif"
formatExtension RenderWebm = "webm"

{-|
Main entry-point for accessing an animation. Creates a program that takes the
following command-line arguments:

> Usage: PROG [COMMAND]
>   This program contains an animation which can either be viewed in a web-browser
>   or rendered to disk.
>
> Available options:
>   -h,--help                Show this help text
>
> Available commands:
>   check                    Run a system's diagnostic and report any missing
>                            external dependencies.
>   view                     Play animation in browser window.
>   render                   Render animation to file.

Neither the \'check\' nor the \'view\' command take any additional arguments.
Rendering animation can be controlled with these arguments:

> Usage: PROG render [-o|--target FILE] [--fps FPS] [-w|--width PIXELS]
>                    [-h|--height PIXELS] [--compile] [--format FMT]
>                    [--preset TYPE]
>   Render animation to file.
>
> Available options:
>   -o,--target FILE         Write output to FILE
>   --fps FPS                Set frames per second.
>   -w,--width PIXELS        Set video width.
>   -h,--height PIXELS       Set video height.
>   --compile                Compile source code before rendering.
>   --format FMT             Video format: mp4, gif, webm
>   --preset TYPE            Parameter presets: youtube, gif, quick
>   -h,--help                Show this help text
-}
reanimate :: Animation -> IO ()
reanimate animation = do
  Options {..} <- getDriverOptions
  case optsCommand of
    Raw {..} -> do
      setFPS 60
      renderSvgs rawOutputFolder rawFrameOffset rawPrettyPrint animation
    Test -> do
      setNoExternals True
      -- hSetBinaryMode stdout True
      renderSnippets animation
    Check       -> checkEnvironment
    View {..}   -> viewAnimation viewDetach animation
    Render {..} -> do
      let fmt =
            guessParameter renderFormat (fmap presetFormat renderPreset)
              $ case renderTarget of
                  -- Format guessed from output
                  Just target -> case takeExtension target of
                    ".mp4"  -> RenderMp4
                    ".gif"  -> RenderGif
                    ".webm" -> RenderWebm
                    _       -> RenderMp4
                  -- Default to mp4 rendering.
                  Nothing -> RenderMp4

      target <- case renderTarget of
        Nothing -> do
          mbSelf <- pure Nothing
          let ext = formatExtension fmt
              self = fromMaybe "output" mbSelf
          pure $ replaceExtension self ext
        Just target -> makeAbsolute target

      let
        fps =
          guessParameter renderFPS (fmap presetFPS renderPreset) $ formatFPS fmt
        (width, height) = fromMaybe
          ( maybe (formatWidth fmt)  presetWidth  renderPreset
          , maybe (formatHeight fmt) presetHeight renderPreset
          )
          (userPreferredDimensions renderWidth renderHeight)

      raster <-
        if renderRaster == RasterNone || renderRaster == RasterAuto  then do
          svgSupport <- hasFFmpegRSvg
          if isRight svgSupport
            then selectRaster renderRaster
            else do
              raster <- selectRaster RasterAuto
              when (raster == RasterNone) $ do
                hPutStrLn stderr
                  "Error: your FFmpeg was built without SVG support and no raster engines \
                  \are available. Please install either inkscape, imagemagick, or rsvg."
                exitWith (ExitFailure 1)
              return raster
        else selectRaster renderRaster
      setRaster raster
      setFPS fps
      setWidth width
      setHeight height
      printf
        "Animation options:\n\
              \  fps:    %d\n\
              \  width:  %d\n\
              \  height: %d\n\
              \  fmt:    %s\n\
              \  target: %s\n\
              \  raster: %s\n"
        fps
        width
        height
        (showFormat fmt)
        target
        (show raster)

      render animation target raster fmt width height fps renderPartial

guessParameter :: Maybe a -> Maybe a -> a -> a
guessParameter a b def = fromMaybe def (a <|> b)


-- If user specifies exactly one dimension explicitly, calculate the other
userPreferredDimensions :: Maybe Width -> Maybe Height -> Maybe (Width, Height)
userPreferredDimensions (Just width) (Just height) = Just (width, height)
userPreferredDimensions (Just width) Nothing =
  Just (width, makeEven $ width * 9 `div` 16)
userPreferredDimensions Nothing (Just height) =
  Just (makeEven $ height * 16 `div` 9, height)
userPreferredDimensions Nothing Nothing = Nothing

-- Avoid ffmpeg failures "height not divisible by 2"
makeEven :: Int -> Int
makeEven x | even x    = x
           | otherwise = x - 1


-- serve viewVerbose viewGHCPath viewGHCOpts viewOrigin
viewAnimation :: Bool -> Animation -> IO ()
viewAnimation _detach animation = do
  detached <- ensureDaemon

  let rate = 60
      count = round (duration animation * rate) :: Int
  sendCommand $ DaemonCount count
  renderSvgs_ animation $ \nth path -> do
    sendCommand $ DaemonFrame nth path

  unless detached $ do
    putStrLn "Daemon mode. Hit ctrl-c to terminate."
    forever $ threadDelay (10^(6::Int))