never executed always true always false
1 {-# LANGUAGE MultiWayIf #-}
2 {-|
3 Copyright : Written by David Himmelstrup
4 License : Unlicense
5 Maintainer : lemmih@gmail.com
6 Stability : experimental
7 Portability : POSIX
8
9 Internal tools for rastering SVGs and rendering videos. You are unlikely
10 to ever directly use the functions in this module.
11
12 -}
13 module Reanimate.Render
14 ( render
15 , renderSvgs
16 , renderSnippets -- :: Animation -> IO ()
17 , renderOneFrame
18 , Format(..)
19 , Raster(..)
20 , Width, Height, FPS
21 , requireRaster -- :: Raster -> IO Raster
22 , selectRaster -- :: Raster -> IO Raster
23 , applyRaster -- :: Raster -> FilePath -> IO ()
24 ) where
25
26 import Control.Concurrent
27 import Control.Exception
28 import Control.Monad (forM_, forever, unless, void, when)
29 import Data.Either
30 import Data.Function
31 import qualified Data.Text as T
32 import qualified Data.Text.IO as T
33 import Data.Time
34 import Graphics.SvgTree (Number (..))
35 import Numeric
36 import Reanimate.Animation
37 import Reanimate.Driver.Check
38 import Reanimate.Driver.Magick
39 import Reanimate.Misc
40 import Reanimate.Parameters
41 import System.Console.ANSI.Codes
42 import System.Exit
43 import System.FileLock (withTryFileLock, SharedExclusive(..), unlockFile)
44 import System.Directory
45 import System.FilePath (replaceExtension, (<.>), (</>))
46 import System.IO
47 import Text.Printf (printf)
48
49 idempotentFile :: FilePath -> IO () -> IO ()
50 idempotentFile path action = do
51 _ <- withTryFileLock lockFile Exclusive $ \lock -> do
52 haveFile <- doesFileExist path
53 unless haveFile action
54 unlockFile lock
55 _ <- try (removeFile lockFile) :: IO (Either SomeException ())
56 return ()
57 return ()
58 where
59 lockFile = path <.> "lock"
60
61 -- | Generate SVGs at 60fps and put them in a folder.
62 renderSvgs :: FilePath -> Int -> Bool -> Animation -> IO ()
63 renderSvgs folder offset _prettyPrint ani = do
64 print frameCount
65 lock <- newMVar ()
66
67 handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do
68 let nth = (nth'+offset) `mod` frameCount
69 now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
70 frame = frameAt (if frameCount <= 1 then 0 else now) ani
71 svg = renderSvg Nothing Nothing frame
72 path = folder </> show nth <.> "svg"
73
74 idempotentFile path $ writeFile path svg
75 withMVar lock $ \_ -> do
76 print nth
77 hFlush stdout
78 where
79 rate = 60
80 frameCount = round (duration ani * fromIntegral rate) :: Int
81 errHandler (ErrorCall msg) = do
82 hPutStrLn stderr msg
83 exitWith (ExitFailure 1)
84
85 -- | Select a single frame that doesn't already exist in the output
86 -- folder and render it. If all frames have been rendered, print "Done".
87 renderOneFrame :: FilePath -> Int -> Bool -> Int -> Animation -> IO ()
88 renderOneFrame folder offset _prettyPrint rate ani =
89 worker (frameOrder rate frameCount)
90 where
91 worker [] = putStrLn "Done"
92 worker (x:xs) = do
93 let nth = (x+offset) `mod` frameCount
94 now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
95 frame = frameAt (if frameCount <= 1 then 0 else now) ani
96 svg = renderSvg Nothing Nothing frame
97 path = folder </> show nth <.> "svg"
98 tmpPath = path <.> "tmp"
99 haveFile <- doesFileExist path
100 if haveFile
101 then worker xs
102 else do
103 writeFile tmpPath svg
104 renameOrCopyFile tmpPath path
105 print nth
106 frameCount = round (duration ani * fromIntegral rate) :: Int
107
108 -- XXX: Merge with 'renderSvgs'
109 -- | Render 10 frames and print them to stdout. Used for testing.
110 --
111 -- XXX: Not related to the snippets in the playground.
112 renderSnippets :: Animation -> IO ()
113 renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do
114 let now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
115 frame = frameAt now ani
116 svg = renderSvg Nothing Nothing frame
117 putStr (show nth)
118 T.putStrLn $ T.concat . T.lines . T.pack $ svg
119 where frameCount = 10 :: Integer
120
121 frameOrder :: Int -> Int -> [Int]
122 frameOrder fps nFrames = worker [] fps
123 where
124 worker _seen 0 = []
125 worker seen nthFrame = filterFrameList seen nthFrame nFrames
126 ++ worker (nthFrame : seen) (nthFrame `div` 2)
127
128 filterFrameList :: [Int] -> Int -> Int -> [Int]
129 filterFrameList seen nthFrame nFrames = filter (not . isSeen)
130 [0, nthFrame .. nFrames - 1]
131 where isSeen x = any (\y -> x `mod` y == 0) seen
132
133 -- | Video formats supported by reanimate.
134 data Format = RenderMp4 | RenderGif | RenderWebm
135 deriving (Show)
136
137 mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
138 mp4Arguments fps progress template target =
139 [ "-r"
140 , show fps
141 , "-i"
142 , template
143 , "-y"
144 , "-c:v"
145 , "libx264"
146 , "-vf"
147 , "fps=" ++ show fps
148 , "-preset"
149 , "slow"
150 , "-crf"
151 , "18"
152 , "-movflags"
153 , "+faststart"
154 , "-progress"
155 , progress
156 , "-pix_fmt"
157 , "yuv420p"
158 , target
159 ]
160
161 -- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
162 -- gifArguments fps progress template target =
163
164 -- | Render animation to a video file with given parameters.
165 render
166 :: Animation
167 -> FilePath
168 -> Raster
169 -> Format
170 -> Width
171 -> Height
172 -> FPS
173 -> Bool
174 -> IO ()
175 render ani target raster format width height fps partial = do
176 printf "Starting render of animation: %.1f\n" (duration ani)
177 ffmpeg <- requireExecutable "ffmpeg"
178 generateFrames raster ani width height fps partial $ \template ->
179 withTempFile "txt" $ \progress -> do
180 writeFile progress ""
181 progressH <- openFile progress ReadMode
182 hSetBuffering progressH NoBuffering
183 allFinished <- newEmptyMVar
184 void $ forkIO $ do
185 progressPrinter "rendered" (animationFrameCount ani fps)
186 $ \done -> fix $ \loop -> do
187 eof <- hIsEOF progressH
188 if eof
189 then threadDelay 1000000 >> loop
190 else do
191 l <- try (hGetLine progressH)
192 case l of
193 Left SomeException{} -> return ()
194 Right str ->
195 case take 6 str of
196 "frame=" -> do
197 void $ swapMVar done (read (drop 6 str))
198 loop
199 _ | str == "progress=end" -> return ()
200 _ -> loop
201 putMVar allFinished ()
202 case format of
203 RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target)
204 RenderGif -> withTempFile "png" $ \palette -> do
205 runCmd
206 ffmpeg
207 [ "-i"
208 , template
209 , "-y"
210 , "-vf"
211 , "fps="
212 ++ show fps
213 ++ ",scale="
214 ++ show width
215 ++ ":"
216 ++ show height
217 ++ ":flags=lanczos,palettegen"
218 , "-t"
219 , showFFloat Nothing (duration ani) ""
220 , palette
221 ]
222 runCmd
223 ffmpeg
224 [ "-framerate"
225 , show fps
226 , "-i"
227 , template
228 , "-y"
229 , "-i"
230 , palette
231 , "-progress"
232 , progress
233 , "-filter_complex"
234 , "fps="
235 ++ show fps
236 ++ ",scale="
237 ++ show width
238 ++ ":"
239 ++ show height
240 ++ ":flags=lanczos[x];[x][1:v]paletteuse"
241 , "-t"
242 , showFFloat Nothing (duration ani) ""
243 , target
244 ]
245 RenderWebm -> runCmd
246 ffmpeg
247 [ "-r"
248 , show fps
249 , "-i"
250 , template
251 , "-y"
252 , "-progress"
253 , progress
254 , "-c:v"
255 , "libvpx-vp9"
256 , "-vf"
257 , "fps=" ++ show fps
258 , target
259 ]
260 takeMVar allFinished
261
262 ---------------------------------------------------------------------------------
263 -- Helpers
264
265 progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO ()
266 progressPrinter typeName maxCount action = do
267 printf "\rFrames %s: 0/%d" typeName maxCount
268 putStr $ clearFromCursorToLineEndCode ++ "\r"
269 done <- newMVar (0 :: Int)
270 start <- getCurrentTime
271 let bgThread = forever $ do
272 nDone <- readMVar done
273 now <- getCurrentTime
274 let spent = diffUTCTime now start
275 remaining =
276 (spent / (fromIntegral nDone / fromIntegral maxCount)) - spent
277 printf "\rFrames %s: %d/%d" typeName nDone maxCount
278 putStr $ ", time spent: " ++ ppDiff spent
279 unless (nDone == 0) $ do
280 putStr $ ", time remaining: " ++ ppDiff remaining
281 putStr $ ", total time: " ++ ppDiff (remaining + spent)
282 putStr $ clearFromCursorToLineEndCode ++ "\r"
283 hFlush stdout
284 threadDelay 1000000
285 withBackgroundThread bgThread $ action done
286 now <- getCurrentTime
287 let spent = diffUTCTime now start
288 printf "\rFrames %s: %d/%d" typeName maxCount maxCount
289 putStr $ ", time spent: " ++ ppDiff spent
290 putStr $ clearFromCursorToLineEndCode ++ "\n"
291
292 animationFrameCount :: Animation -> FPS -> Int
293 animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int
294
295 generateFrames
296 :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a
297 generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do
298 let frameName nth = tmp </> printf nameTemplate nth
299 setRootDirectory tmp
300 progressPrinter "generated" frameCount
301 $ \done -> handle h $ concurrentForM_ frames $ \n -> do
302 writeFile (frameName n) $ renderSvg width height $ nthFrame n
303 modifyMVar_ done $ \nDone -> return (nDone + 1)
304
305 when (isValidRaster raster)
306 $ progressPrinter "rastered" frameCount
307 $ \done -> handle h $ concurrentForM_ frames $ \n -> do
308 applyRaster raster (frameName n)
309 modifyMVar_ done $ \nDone -> return (nDone + 1)
310
311 action (tmp </> rasterTemplate raster)
312 where
313 isValidRaster RasterNone = False
314 isValidRaster RasterAuto = False
315 isValidRaster _ = True
316
317 width = Just $ Px $ fromIntegral width_
318 height = Just $ Px $ fromIntegral height_
319 h UserInterrupt | partial = do
320 hPutStrLn
321 stderr
322 "\nCtrl-C detected. Trying to generate video with available frames. \
323 \Hit ctrl-c again to abort."
324 return ()
325 h other = throwIO other
326 -- frames = [0..frameCount-1]
327 frames = frameOrder rate frameCount
328 nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
329 frameCount = animationFrameCount ani rate
330 nameTemplate :: String
331 nameTemplate = "render-%05d.svg"
332
333 withBackgroundThread :: IO () -> IO a -> IO a
334 withBackgroundThread t = bracket (forkIO t) killThread . const
335
336 ppDiff :: NominalDiffTime -> String
337 ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s"
338 | hours == 0 = printf "%.2d:%.2d" mins secs
339 | otherwise = printf "%.2d:%.2d:%.2d" hours mins secs
340 where
341 (osecs, secs) = round diff `divMod` (60 :: Int)
342 (hours, mins) = osecs `divMod` 60
343
344 rasterTemplate :: Raster -> String
345 rasterTemplate RasterNone = "render-%05d.svg"
346 rasterTemplate RasterAuto = "render-%05d.svg"
347 rasterTemplate _ = "render-%05d.png"
348
349 -- | Resolve RasterNone and RasterAuto. If no valid raster can
350 -- be found, exit with an error message.
351 requireRaster :: Raster -> IO Raster
352 requireRaster raster = do
353 raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster)
354 case raster' of
355 RasterNone -> do
356 hPutStrLn
357 stderr
358 "Raster required but none could be found. \
359 \Please install either inkscape, imagemagick, or rsvg-convert."
360 exitWith (ExitFailure 1)
361 _ -> pure raster'
362
363 -- | Resolve RasterNone and RasterAuto. If no valid raster can
364 -- be found, return RasterNone.
365 selectRaster :: Raster -> IO Raster
366 selectRaster RasterAuto = do
367 rsvg <- hasRSvg
368 ink <- hasInkscape
369 magick <- hasMagick
370 if
371 | isRight rsvg -> pure RasterRSvg
372 | isRight ink -> pure RasterInkscape
373 | isRight magick -> pure RasterMagick
374 | otherwise -> pure RasterNone
375 selectRaster r = pure r
376
377 -- | Convert SVG file to a PNG file with selected raster engine. If
378 -- raster engine is RasterAuto or RasterNone, do nothing.
379 applyRaster :: Raster -> FilePath -> IO ()
380 applyRaster RasterNone _ = return ()
381 applyRaster RasterAuto _ = return ()
382 applyRaster RasterInkscape path = runCmd
383 "inkscape"
384 [ "--without-gui"
385 , "--file=" ++ path
386 , "--export-png=" ++ replaceExtension path "png"
387 ]
388 applyRaster RasterRSvg path = runCmd
389 "rsvg-convert"
390 [path, "--unlimited", "--output", replaceExtension path "png"]
391 applyRaster RasterMagick path =
392 runCmd magickCmd [path, replaceExtension path "png"]
393
394 concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
395 concurrentForM_ lst action = do
396 n <- getNumCapabilities
397 sem <- newQSemN n
398 eVar <- newEmptyMVar
399 forM_ lst $ \elt -> do
400 waitQSemN sem 1
401 emp <- isEmptyMVar eVar
402 if emp
403 then
404 void
405 $ forkIO
406 ( catch (action elt) (void . tryPutMVar eVar)
407 `finally` signalQSemN sem 1
408 )
409 else signalQSemN sem 1
410 waitQSemN sem n
411 mbE <- tryTakeMVar eVar
412 case mbE of
413 Nothing -> return ()
414 Just e -> throwIO (e :: SomeException)