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