diff --git a/haddock.txt b/haddock.txt index 1082b7d..103fd8d 100644 --- a/haddock.txt +++ b/haddock.txt @@ -22,7 +22,7 @@ 44% ( 4 / 9) in 'Reanimate.LaTeX' 42% ( 47 /111) in 'Reanimate.Scene' 42% ( 17 / 40) in 'Reanimate.GeoProjection' - 33% ( 4 / 12) in 'Reanimate.Render' + 31% ( 4 / 13) in 'Reanimate.Render' 25% ( 1 / 4) in 'Reanimate.Builtin.Slide' 12% ( 2 / 17) in 'Reanimate.Math.SSSP' 10% ( 3 / 30) in 'Reanimate.PolyShape' diff --git a/haddock_badge.json b/haddock_badge.json index da8cf6c..f66b041 100644 --- a/haddock_badge.json +++ b/haddock_badge.json @@ -1 +1 @@ - { "schemaVersion": 1, "label": "api docs", "message": "53%", "color": "success" } + { "schemaVersion": 1, "label": "api docs", "message": "52%", "color": "success" } diff --git a/hpc_index.html b/hpc_index.html index b9959e2..8e9116a 100644 --- a/hpc_index.html +++ b/hpc_index.html @@ -101,7 +101,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 15%2/13
0%0/17
11%52/443
  module reanimate-0.4.1.0-inplace/Reanimate.Render -5%1/18
0%0/44
5%39/762
+5%1/19
0%0/50
4%39/826
  module reanimate-0.4.1.0-inplace/Reanimate.Scene 31%40/128
60%15/25
36%545/1476
@@ -128,5 +128,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 100%6/6
50%1/2
95%43/45
  Program Coverage Total -30%247/802
15%131/827
29%4647/15836
+30%247/803
15%131/833
29%4647/15900
diff --git a/hpc_index_alt.html b/hpc_index_alt.html index dd9efee..0115d44 100644 --- a/hpc_index_alt.html +++ b/hpc_index_alt.html @@ -101,7 +101,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 15%2/13
0%0/17
11%52/443
  module reanimate-0.4.1.0-inplace/Reanimate.Render -5%1/18
0%0/44
5%39/762
+5%1/19
0%0/50
4%39/826
  module reanimate-0.4.1.0-inplace/Reanimate.Svg.Unuse 33%1/3
0%0/14
21%28/128
@@ -128,5 +128,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 15%3/20
- 0/0 14%7/49
  Program Coverage Total -30%247/802
15%131/827
29%4647/15836
+30%247/803
15%131/833
29%4647/15900
diff --git a/hpc_index_exp.html b/hpc_index_exp.html index d5b2114..0cbf2b7 100644 --- a/hpc_index_exp.html +++ b/hpc_index_exp.html @@ -86,7 +86,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 33%4/12
11%1/9
7%12/167
  module reanimate-0.4.1.0-inplace/Reanimate.Render -5%1/18
0%0/44
5%39/762
+5%1/19
0%0/50
4%39/826
  module reanimate-0.4.1.0-inplace/Reanimate.Driver 8%1/12
1%1/55
3%9/246
@@ -128,5 +128,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 0%0/1
0%0/4
0%0/61
  Program Coverage Total -30%247/802
15%131/827
29%4647/15836
+30%247/803
15%131/833
29%4647/15900
diff --git a/hpc_index_fun.html b/hpc_index_fun.html index bf82e5f..0092753 100644 --- a/hpc_index_fun.html +++ b/hpc_index_fun.html @@ -92,7 +92,7 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 8%7/82
5%4/79
2%58/2494
  module reanimate-0.4.1.0-inplace/Reanimate.Render -5%1/18
0%0/44
5%39/762
+5%1/19
0%0/50
4%39/826
  module reanimate-0.4.1.0-inplace/Reanimate.Cache 0%0/8
0%0/12
0%0/160
@@ -128,5 +128,5 @@ table.dashboard { border-collapse: collapse ; border: solid 1px black } 0%0/1
0%0/4
0%0/61
  Program Coverage Total -30%247/802
15%131/827
29%4647/15836
+30%247/803
15%131/833
29%4647/15900
diff --git a/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html b/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html index 0089522..c39fe23 100644 --- a/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html +++ b/reanimate-0.4.1.0-inplace/Reanimate.Render.hs.html @@ -22,368 +22,390 @@ span.spaces { background: white } 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 + 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 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) + 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)