module Reanimate.Render
( render
, renderSvgs
, renderSnippets
, Format(..)
, Raster(..)
, Width, Height, FPS
, applyRaster
) where
import Control.Concurrent
import Control.Exception
import Control.Monad (forM_, void, unless, forever)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time
import Graphics.SvgTree (Number (..))
import Numeric
import Reanimate.Animation
import Reanimate.Misc
import Reanimate.Parameters
import System.Exit
import System.FilePath ((</>))
import System.FilePath (replaceExtension)
import System.IO
import Text.Printf (printf)
renderSvgs :: Animation -> IO ()
renderSvgs ani = do
print frameCount
lock <- newMVar ()
handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth -> do
let
now = (duration ani / (fromIntegral frameCount-1)) * fromIntegral nth
frame = frameAt (if frameCount<=1 then 0 else now) ani
svg = renderSvg Nothing Nothing frame
_ <- evaluate (length svg)
withMVar lock $ \_ -> do
putStr (show nth)
T.putStrLn $ T.concat . T.lines . T.pack $ svg
hFlush stdout
where
rate = 60
frameCount = round (duration ani * fromIntegral rate) :: Int
errHandler (ErrorCall msg) = do
hPutStrLn stderr msg
exitWith (ExitFailure 1)
renderSnippets :: Animation -> IO ()
renderSnippets ani =
forM_ [0..frameCount-1] $ \nth -> do
let now = (duration ani / (fromIntegral frameCount-1)) * fromIntegral nth
frame = frameAt now ani
svg = renderSvg Nothing Nothing frame
putStr (show nth)
T.putStrLn $ T.concat . T.lines . T.pack $ svg
where
frameCount = 50 :: Integer
frameOrder :: Int -> Int -> [Int]
frameOrder fps nFrames = worker [] fps
where
worker _seen 0 = []
worker seen nthFrame =
filterFrameList seen nthFrame nFrames ++
worker (nthFrame : seen) (nthFrame `div` 2)
filterFrameList :: [Int] -> Int -> Int -> [Int]
filterFrameList seen nthFrame nFrames =
filter (not.isSeen) [0, nthFrame .. nFrames-1]
where
isSeen x = any (\y -> x `mod` y == 0) seen
data Format = RenderMp4 | RenderGif | RenderWebm
deriving (Show)
render :: Animation
-> FilePath
-> Raster
-> Format
-> Width
-> Height
-> FPS
-> IO ()
render ani target raster format width height fps = do
printf "Starting render of animation: %.1f\n" (duration ani)
ffmpeg <- requireExecutable "ffmpeg"
generateFrames raster ani width height fps $ \template ->
withTempFile "txt" $ \progress -> writeFile progress "" >>
case format of
RenderMp4 ->
runCmd ffmpeg ["-r", show fps, "-i", template, "-y"
, "-c:v", "libx264", "-vf", "fps="++show fps
, "-preset", "slow"
, "-crf", "18"
, "-movflags", "+faststart"
, "-progress", progress
, "-pix_fmt", "yuv420p", target]
RenderGif -> withTempFile "png" $ \palette -> do
runCmd ffmpeg ["-i", template, "-y"
,"-vf", "fps="++show fps++",scale=320:-1:flags=lanczos,palettegen"
,"-t", showFFloat Nothing (duration ani) ""
, palette ]
runCmd ffmpeg ["-framerate", show fps,"-i", template, "-y"
,"-i", palette
,"-progress", progress
,"-filter_complex"
,"fps="++show fps++",scale=320:-1:flags=lanczos[x];[x][1:v]paletteuse"
,"-t", showFFloat Nothing (duration ani) ""
, target]
RenderWebm ->
runCmd ffmpeg ["-r", show fps, "-i", template, "-y"
,"-progress", progress
, "-c:v", "libvpx-vp9", "-vf", "fps="++show fps
, target]
generateFrames :: Raster -> Animation -> Width -> Height -> FPS -> (FilePath -> IO a) -> IO a
generateFrames raster ani width_ height_ rate action = withTempDir $ \tmp -> do
setRootDirectory tmp
done <- newMVar (0::Int)
let frameName nth = tmp </> printf nameTemplate nth
putStr $ "\rFrames rendered: 0/" ++ show frameCount ++ "\27[K\r"
hFlush stdout
start <- getCurrentTime
let statusPrinter = forever $ do
nDone <- readMVar done
now <- getCurrentTime
let spent = diffUTCTime now start
remaining = (spent / (fromIntegral nDone / fromIntegral frameCount)) - spent
putStr $ "\rFrames rendered: " ++ show nDone ++ "/" ++ show frameCount
putStr $ ", time spent: " ++ ppDiff spent
unless (nDone==0) $ do
putStr $ ", time remaining: " ++ ppDiff remaining
putStr $ ", total time: " ++ ppDiff (remaining+spent)
putStr $ "\27[K\r"
hFlush stdout
threadDelay 1000000
withBackgroundThread statusPrinter $ do
handle h $ concurrentForM_ frames $ \n -> do
writeFile (frameName n) $ renderSvg width height $ nthFrame n
applyRaster raster (frameName n)
modifyMVar_ done $ \nDone -> return (nDone+1)
now <- getCurrentTime
let spent = diffUTCTime now start
putStr $ "\rFrames rendered: " ++ show frameCount ++ "/" ++ show frameCount
putStr $ ", time spent: " ++ ppDiff spent
putStr $ "\27[K\n"
action (tmp </> rasterTemplate raster)
where
width = Just $ Px $ fromIntegral width_
height = Just $ Px $ fromIntegral height_
h UserInterrupt = do
hPutStrLn stderr "\nCtrl-C detected. Trying to generate video with available frames. \
\Hit ctrl-c again to abort."
return ()
h other = throwIO other
frames = frameOrder rate frameCount
nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
frameCount = round (duration ani * fromIntegral rate) :: Int
nameTemplate :: String
nameTemplate = "render-%05d.svg"
withBackgroundThread :: IO () -> IO a -> IO a
withBackgroundThread t = bracket (forkIO t) killThread . const
ppDiff :: NominalDiffTime -> String
ppDiff diff
| hours == 0 && mins == 0 = show secs ++ "s"
| hours == 0 = printf "%.2d:%.2d" mins secs
| otherwise = printf "%.2d:%.2d:%.2d" hours mins secs
where
(osecs, secs) = round diff `divMod` (60::Int)
(hours, mins) = osecs `divMod` 60
rasterTemplate :: Raster -> String
rasterTemplate RasterNone = "render-%05d.svg"
rasterTemplate _ = "render-%05d.png"
applyRaster :: Raster -> FilePath -> IO ()
applyRaster RasterNone _ = return ()
applyRaster RasterAuto _ = return ()
applyRaster RasterInkscape path =
runCmd "inkscape"
[ "--without-gui"
, "--file=" ++ path
, "--export-png=" ++ replaceExtension path "png" ]
applyRaster RasterRSvg path =
runCmd "rsvg-convert"
[ path
, "--unlimited"
, "--output", replaceExtension path "png" ]
applyRaster RasterConvert path =
runCmd "convert"
[ path
, replaceExtension path "png" ]
concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
concurrentForM_ lst action = do
n <- getNumCapabilities
sem <- newQSemN n
eVar <- newEmptyMVar
forM_ lst $ \elt -> do
waitQSemN sem 1
emp <- isEmptyMVar eVar
if emp
then void $ forkIO (catch (action elt) (void . tryPutMVar eVar) `finally` signalQSemN sem 1)
else signalQSemN sem 1
waitQSemN sem n
mbE <- tryTakeMVar eVar
case mbE of
Nothing -> return ()
Just e -> throwIO (e :: SomeException)