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 , renderLimitedFrames
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 -- | Render as many frames as possible in 2 seconds. Limited to 20 frames.
86 renderLimitedFrames :: FilePath -> Int -> Bool -> Int -> Animation -> IO ()
87 renderLimitedFrames folder offset _prettyPrint rate ani = do
88 now <- getCurrentTime
89 worker (addUTCTime timeLimit now) frameLimit (frameOrder rate frameCount)
90 where
91 timeLimit = 2
92 frameLimit = 20 :: Int
93 worker _ 0 _ = return ()
94 worker _ _ [] = putStrLn "Done"
95 worker localTimeLimit l (x:xs) = do
96 curTime <- getCurrentTime
97 if curTime > localTimeLimit
98 then return ()
99 else do
100 let nth = (x+offset) `mod` frameCount
101 now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
102 frame = frameAt (if frameCount <= 1 then 0 else now) ani
103 svg = renderSvg Nothing Nothing frame
104 path = folder </> show nth <.> "svg"
105 tmpPath = path <.> "tmp"
106 haveFile <- doesFileExist path
107 if haveFile
108 then worker localTimeLimit l xs
109 else do
110 writeFile tmpPath svg
111 renameOrCopyFile tmpPath path
112 print nth
113 worker localTimeLimit (l-1) xs
114 frameCount = round (duration ani * fromIntegral rate) :: Int
115
116 -- XXX: Merge with 'renderSvgs'
117 -- | Render 10 frames and print them to stdout. Used for testing.
118 --
119 -- XXX: Not related to the snippets in the playground.
120 renderSnippets :: Animation -> IO ()
121 renderSnippets ani = forM_ [0 .. frameCount - 1] $ \nth -> do
122 let now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth
123 frame = frameAt now ani
124 svg = renderSvg Nothing Nothing frame
125 putStr (show nth)
126 T.putStrLn $ T.concat . T.lines . T.pack $ svg
127 where frameCount = 10 :: Integer
128
129 frameOrder :: Int -> Int -> [Int]
130 frameOrder fps nFrames = worker [] fps
131 where
132 worker _seen 0 = []
133 worker seen nthFrame = filterFrameList seen nthFrame nFrames
134 ++ worker (nthFrame : seen) (nthFrame `div` 2)
135
136 filterFrameList :: [Int] -> Int -> Int -> [Int]
137 filterFrameList seen nthFrame nFrames = filter (not . isSeen)
138 [0, nthFrame .. nFrames - 1]
139 where isSeen x = any (\y -> x `mod` y == 0) seen
140
141 -- | Video formats supported by reanimate.
142 data Format = RenderMp4 | RenderGif | RenderWebm
143 deriving (Show)
144
145 mp4Arguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
146 mp4Arguments fps progress template target =
147 [ "-r"
148 , show fps
149 , "-i"
150 , template
151 , "-y"
152 , "-c:v"
153 , "libx264"
154 , "-vf"
155 , "fps=" ++ show fps
156 , "-preset"
157 , "slow"
158 , "-crf"
159 , "18"
160 , "-movflags"
161 , "+faststart"
162 , "-progress"
163 , progress
164 , "-pix_fmt"
165 , "yuv420p"
166 , target
167 ]
168
169 -- gifArguments :: FPS -> FilePath -> FilePath -> FilePath -> [String]
170 -- gifArguments fps progress template target =
171
172 -- | Render animation to a video file with given parameters.
173 render
174 :: Animation
175 -> FilePath
176 -> Raster
177 -> Format
178 -> Width
179 -> Height
180 -> FPS
181 -> Bool
182 -> IO ()
183 render ani target raster format width height fps partial = do
184 printf "Starting render of animation: %.1f\n" (duration ani)
185 ffmpeg <- requireExecutable "ffmpeg"
186 generateFrames raster ani width height fps partial $ \template ->
187 withTempFile "txt" $ \progress -> do
188 writeFile progress ""
189 progressH <- openFile progress ReadMode
190 hSetBuffering progressH NoBuffering
191 allFinished <- newEmptyMVar
192 void $ forkIO $ do
193 progressPrinter "rendered" (animationFrameCount ani fps)
194 $ \done -> fix $ \loop -> do
195 eof <- hIsEOF progressH
196 if eof
197 then threadDelay 1000000 >> loop
198 else do
199 l <- try (hGetLine progressH)
200 case l of
201 Left SomeException{} -> return ()
202 Right str ->
203 case take 6 str of
204 "frame=" -> do
205 void $ swapMVar done (read (drop 6 str))
206 loop
207 _ | str == "progress=end" -> return ()
208 _ -> loop
209 putMVar allFinished ()
210 case format of
211 RenderMp4 -> runCmd ffmpeg (mp4Arguments fps progress template target)
212 RenderGif -> withTempFile "png" $ \palette -> do
213 runCmd
214 ffmpeg
215 [ "-i"
216 , template
217 , "-y"
218 , "-vf"
219 , "fps="
220 ++ show fps
221 ++ ",scale="
222 ++ show width
223 ++ ":"
224 ++ show height
225 ++ ":flags=lanczos,palettegen"
226 , "-t"
227 , showFFloat Nothing (duration ani) ""
228 , palette
229 ]
230 runCmd
231 ffmpeg
232 [ "-framerate"
233 , show fps
234 , "-i"
235 , template
236 , "-y"
237 , "-i"
238 , palette
239 , "-progress"
240 , progress
241 , "-filter_complex"
242 , "fps="
243 ++ show fps
244 ++ ",scale="
245 ++ show width
246 ++ ":"
247 ++ show height
248 ++ ":flags=lanczos[x];[x][1:v]paletteuse"
249 , "-t"
250 , showFFloat Nothing (duration ani) ""
251 , target
252 ]
253 RenderWebm -> runCmd
254 ffmpeg
255 [ "-r"
256 , show fps
257 , "-i"
258 , template
259 , "-y"
260 , "-progress"
261 , progress
262 , "-c:v"
263 , "libvpx-vp9"
264 , "-vf"
265 , "fps=" ++ show fps
266 , target
267 ]
268 takeMVar allFinished
269
270 ---------------------------------------------------------------------------------
271 -- Helpers
272
273 progressPrinter :: String -> Int -> (MVar Int -> IO ()) -> IO ()
274 progressPrinter typeName maxCount action = do
275 printf "\rFrames %s: 0/%d" typeName maxCount
276 putStr $ clearFromCursorToLineEndCode ++ "\r"
277 done <- newMVar (0 :: Int)
278 start <- getCurrentTime
279 let bgThread = forever $ do
280 nDone <- readMVar done
281 now <- getCurrentTime
282 let spent = diffUTCTime now start
283 remaining =
284 (spent / (fromIntegral nDone / fromIntegral maxCount)) - spent
285 printf "\rFrames %s: %d/%d" typeName nDone maxCount
286 putStr $ ", time spent: " ++ ppDiff spent
287 unless (nDone == 0) $ do
288 putStr $ ", time remaining: " ++ ppDiff remaining
289 putStr $ ", total time: " ++ ppDiff (remaining + spent)
290 putStr $ clearFromCursorToLineEndCode ++ "\r"
291 hFlush stdout
292 threadDelay 1000000
293 withBackgroundThread bgThread $ action done
294 now <- getCurrentTime
295 let spent = diffUTCTime now start
296 printf "\rFrames %s: %d/%d" typeName maxCount maxCount
297 putStr $ ", time spent: " ++ ppDiff spent
298 putStr $ clearFromCursorToLineEndCode ++ "\n"
299
300 animationFrameCount :: Animation -> FPS -> Int
301 animationFrameCount ani rate = round (duration ani * fromIntegral rate) :: Int
302
303 generateFrames
304 :: Raster -> Animation -> Width -> Height -> FPS -> Bool -> (FilePath -> IO a) -> IO a
305 generateFrames raster ani width_ height_ rate partial action = withTempDir $ \tmp -> do
306 let frameName nth = tmp </> printf nameTemplate nth
307 setRootDirectory tmp
308 progressPrinter "generated" frameCount
309 $ \done -> handle h $ concurrentForM_ frames $ \n -> do
310 writeFile (frameName n) $ renderSvg width height $ nthFrame n
311 modifyMVar_ done $ \nDone -> return (nDone + 1)
312
313 when (isValidRaster raster)
314 $ progressPrinter "rastered" frameCount
315 $ \done -> handle h $ concurrentForM_ frames $ \n -> do
316 applyRaster raster (frameName n)
317 modifyMVar_ done $ \nDone -> return (nDone + 1)
318
319 action (tmp </> rasterTemplate raster)
320 where
321 isValidRaster RasterNone = False
322 isValidRaster RasterAuto = False
323 isValidRaster _ = True
324
325 width = Just $ Px $ fromIntegral width_
326 height = Just $ Px $ fromIntegral height_
327 h UserInterrupt | partial = do
328 hPutStrLn
329 stderr
330 "\nCtrl-C detected. Trying to generate video with available frames. \
331 \Hit ctrl-c again to abort."
332 return ()
333 h other = throwIO other
334 -- frames = [0..frameCount-1]
335 frames = frameOrder rate frameCount
336 nthFrame nth = frameAt (recip (fromIntegral rate) * fromIntegral nth) ani
337 frameCount = animationFrameCount ani rate
338 nameTemplate :: String
339 nameTemplate = "render-%05d.svg"
340
341 withBackgroundThread :: IO () -> IO a -> IO a
342 withBackgroundThread t = bracket (forkIO t) killThread . const
343
344 ppDiff :: NominalDiffTime -> String
345 ppDiff diff | hours == 0 && mins == 0 = show secs ++ "s"
346 | hours == 0 = printf "%.2d:%.2d" mins secs
347 | otherwise = printf "%.2d:%.2d:%.2d" hours mins secs
348 where
349 (osecs, secs) = round diff `divMod` (60 :: Int)
350 (hours, mins) = osecs `divMod` 60
351
352 rasterTemplate :: Raster -> String
353 rasterTemplate RasterNone = "render-%05d.svg"
354 rasterTemplate RasterAuto = "render-%05d.svg"
355 rasterTemplate _ = "render-%05d.png"
356
357 -- | Resolve RasterNone and RasterAuto. If no valid raster can
358 -- be found, exit with an error message.
359 requireRaster :: Raster -> IO Raster
360 requireRaster raster = do
361 raster' <- selectRaster (if raster == RasterNone then RasterAuto else raster)
362 case raster' of
363 RasterNone -> do
364 hPutStrLn
365 stderr
366 "Raster required but none could be found. \
367 \Please install either inkscape, imagemagick, or rsvg-convert."
368 exitWith (ExitFailure 1)
369 _ -> pure raster'
370
371 -- | Resolve RasterNone and RasterAuto. If no valid raster can
372 -- be found, return RasterNone.
373 selectRaster :: Raster -> IO Raster
374 selectRaster RasterAuto = do
375 rsvg <- hasRSvg
376 ink <- hasInkscape
377 magick <- hasMagick
378 if
379 | isRight rsvg -> pure RasterRSvg
380 | isRight ink -> pure RasterInkscape
381 | isRight magick -> pure RasterMagick
382 | otherwise -> pure RasterNone
383 selectRaster r = pure r
384
385 -- | Convert SVG file to a PNG file with selected raster engine. If
386 -- raster engine is RasterAuto or RasterNone, do nothing.
387 applyRaster :: Raster -> FilePath -> IO ()
388 applyRaster RasterNone _ = return ()
389 applyRaster RasterAuto _ = return ()
390 applyRaster RasterInkscape path = runCmd
391 "inkscape"
392 [ "--without-gui"
393 , "--file=" ++ path
394 , "--export-png=" ++ replaceExtension path "png"
395 ]
396 applyRaster RasterRSvg path = runCmd
397 "rsvg-convert"
398 [path, "--unlimited", "--output", replaceExtension path "png"]
399 applyRaster RasterMagick path =
400 runCmd magickCmd [path, replaceExtension path "png"]
401
402 concurrentForM_ :: [a] -> (a -> IO ()) -> IO ()
403 concurrentForM_ lst action = do
404 n <- getNumCapabilities
405 sem <- newQSemN n
406 eVar <- newEmptyMVar
407 forM_ lst $ \elt -> do
408 waitQSemN sem 1
409 emp <- isEmptyMVar eVar
410 if emp
411 then
412 void
413 $ forkIO
414 ( catch (action elt) (void . tryPutMVar eVar)
415 `finally` signalQSemN sem 1
416 )
417 else signalQSemN sem 1
418 waitQSemN sem n
419 mbE <- tryTakeMVar eVar
420 case mbE of
421 Nothing -> return ()
422 Just e -> throwIO (e :: SomeException)