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