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