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