diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# 0.12.0 + +* Refactoring to better interoperate with SDL2 +* SDL2 video player demo executable + +[Thanks to Vladimir Pankov!] + # 0.11.1 * Use `Control.Monad.Except` instead of the deprecated `Control.Monad.Error` (Issue reported by Alexander / @AleXoundOS) diff --git a/demo/VPlay.hs b/demo/VPlay.hs new file mode 100644 --- /dev/null +++ b/demo/VPlay.hs @@ -0,0 +1,316 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Codec.FFmpeg +import Codec.FFmpeg.Common +import Codec.FFmpeg.Decode hiding (av_malloc) + +import Control.Concurrent.MVar (newMVar, takeMVar, putMVar) +import Control.Monad.Except +import Control.Monad.Loops +import Control.Monad.Trans.Maybe + +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafePackCStringFinalizer) +import Data.Text (Text) + +import Foreign.C.Types +import Foreign.Ptr + +import System.Environment + +import qualified SDL as SDL + + +{- Auxiliary. -} + +-- Prepare input source: open, check for streams. +prepareInput :: (MonadIO m, MonadError String m) + => InputSource + -> m AVFormatContext +prepareInput inp = + openInput inp >>= \ ctx -> checkStreams ctx >> return ctx + +-- Prepare video codec: find video stream, open. +prepareVideoCodec :: (MonadIO m, MonadError String m) + => AVFormatContext + -> m ( CInt + , AVCodecContext + , AVCodec + , AVStream + , AVDictionary ) +prepareVideoCodec inpCtx = do + (vidStreamIndex, ctx, cod, vidStream) <- findVideoStream inpCtx + dict <- openCodec ctx cod + return (vidStreamIndex, ctx, cod, vidStream, dict) + +-- Transform reader to return timestamp too. +readTS :: (HasPts f, Fractional t) + => AVRational + -> IO (Maybe f) + -> IO (Maybe (f, t)) +readTS (AVRational num den) reader = + -- It's part of frameReaderTime definition. + let (numl, dend) = (fromIntegral num, fromIntegral den) + frameTime' frame = + do n <- getPts frame + return $ fromIntegral (n * numl) / dend + reader' = do frame <- reader + case frame of + Nothing -> return Nothing + Just f -> do t <- frameTime' f + return $ Just (f, t) in reader' + +-- Transform frame and timestamp reader to compute frame +-- time as a difference between adjacent timestamps. +readTSDiff :: (MonadIO m, MonadIO m', Num t) + => m' (Maybe (f, t)) -> m (m' (Maybe (f, t))) +readTSDiff readerTS = do + timeVar <- liftIO $ newMVar 0 + let reader = runMaybeT $ do + (f, currTime) <- MaybeT readerTS + prevTime <- takeTime + putTime currTime + let timeDiff = currTime - prevTime + return (f, timeDiff) + where + takeTime = liftIO . takeMVar $ timeVar + putTime = liftIO . putMVar timeVar + return reader + +-- Transformer version of updateTextureByFrame. +updateTextureByFrameT :: SDL.Texture -> AVFrame -> MaybeT IO SDL.Texture +updateTextureByFrameT texture frame = + copyImageDataT frame >>= updateTexture texture + where + updateTexture t img = + frameLineSizeT frame >>= + SDL.updateTexture t Nothing img + +-- Update texture by image data from frame. +updateTextureByFrame :: SDL.Texture -> AVFrame -> IO (Maybe SDL.Texture) +updateTextureByFrame t = runMaybeT . updateTextureByFrameT t + +-- Return Nothing when condition holds. +nothingWhen + :: Monad m + => m a -> (a -> Bool) -> m (Maybe b) -> m (Maybe b) +nothingWhen g p action = do + -- Generate conditional. + a <- g + -- Check predicate. + if p a + then return Nothing + else action + +-- Retrun Nothing when QuitEvent is received. +nothingOnQuit + :: MonadIO m + => m (Maybe a) -> m (Maybe a) +nothingOnQuit action = + nothingWhen + SDL.pollEvents + (not . null . filter + (\ event -> + case SDL.eventPayload event of + SDL.QuitEvent -> True + _ -> False)) action + +{- Return ByteString filled by image data from frame. + + Returned ByteString doesn't refer back to it's + source AVFrame. So, source frame may be deleted + or changed, but image will stay. + +-} +copyImageData :: AVFrame -> IO (Maybe ByteString) +copyImageData frame = + runMaybeT $ do + + -- Get required size of buffer to hold image data. + imageBufSize <- frameBufferSizeT frame + + -- Allocate buffer to hold image data. + imageBuf <- MaybeT $ + Just <$> (av_malloc $ fromIntegral imageBufSize) + + -- Image data buffer cleanup. + let imageBufCleanup = av_free imageBuf + + -- Copy image to buffer. + _ <- frameCopyToBufferT frame (castPtr imageBuf) + + -- Fill up byte-string by data from buffer. + MaybeT $ Just <$> + unsafePackCStringFinalizer + (castPtr imageBuf) + (fromIntegral imageBufSize) + -- Cleanup for buffer. + imageBufCleanup + +-- Transformer version of copyImageData. +copyImageDataT :: AVFrame -> MaybeT IO ByteString +copyImageDataT = MaybeT . copyImageData + +-- Convert floating point second to millisecond. +sec2msec :: (RealFrac a, Integral b) => a -> b +sec2msec = floor . (*1000) + +-- Adjust window size by display size. +-- It uses first display retrieved from call to SDL.getDisplays. +-- I don't know yet how to get a display where window is opened. +-- So this function won't be used right now. +adjustWindowSize :: MonadIO m => SDL.Window -> m () +adjustWindowSize w = do + (SDL.V2 ww wh) <- SDL.get (SDL.windowSize w) + (SDL.V2 dw dh) <- SDL.displayBoundsSize <$> firstDisplay + let w' = min ww dw + h' = min wh dh + (SDL.windowSize w) SDL.$= (SDL.V2 w' h') + where + firstDisplay = SDL.getDisplays >>= return . head + + +{- Main. -} + +-- Configuration for video player. +data Config = + Config + { cfgWindowTitle :: Text + , cfgRendererDriver :: CInt + , cfgFmtFFmpeg :: AVPixelFormat + , cfgFmtSDL :: SDL.PixelFormat + } + +videoPlayer + :: (MonadIO m, MonadError String m) + => Config -> InputSource -> m () +videoPlayer cfg src = do + + {- Setup. -} + + liftIO initFFmpeg + SDL.initializeAll + + (renderTexture, getTexture, cleanup) <- textureReader src + + liftIO $ whileJust_ (nothingOnQuit getTexture) $ + \ (next, time) -> do + + {- Rendering. -} + + -- Rendering start time. + rStartTime <- SDL.time + + renderTexture next + + -- Finish time of rendering. + rFinishTime <- SDL.time + + {- Synchronizing. -} + + -- Total rendering time. + let rTotalTime = sec2msec $ rFinishTime - rStartTime + -- Frame time in MS. + frameTime = sec2msec time + + -- If rendering time is less then frame time. + when ( time > 0 && rTotalTime < frameTime) $ do + -- Sleep their difference. + SDL.delay $ frameTime - rTotalTime + + {- Cleanup. -} + + liftIO cleanup + SDL.quit + + where + + -- Create window using title from config. + createWindow w h = do + window <- SDL.createWindow (cfgWindowTitle cfg) SDL.defaultWindow + (SDL.$=) (SDL.windowSize window) (SDL.V2 w h) + return window + + -- Create renderer using driver from config. + createRenderer window = + SDL.createRenderer window (cfgRendererDriver cfg) SDL.defaultRenderer + + -- Create texture using pixel format from config. + createTexture renderer w h = + SDL.createTexture + renderer + (cfgFmtSDL cfg) + SDL.TextureAccessStreaming + (SDL.V2 w h) + + -- Return texture reader, renderer and cleanup. + textureReader :: (MonadIO m', MonadError String m', MonadIO m) + => InputSource + -> m' ( SDL.Texture -> m () + , IO (Maybe (SDL.Texture, Double)) + , IO ()) + textureReader inp = do + + -- Open video. + inputContext <- prepareInput inp + (vsIdx, ctx, _, vs, _) <- prepareVideoCodec inputContext + + -- Get frame size. + w <- liftIO $ getWidth ctx + h <- liftIO $ getHeight ctx + + -- Create window, renderer and texture. + window <- createWindow w h + renderer <- createRenderer window + texture <- createTexture renderer w h + + -- Create frame reader. + let dstFmt = cfgFmtFFmpeg cfg + (reader, cleanup) <- prepareReader inputContext vsIdx dstFmt ctx + + -- Transform reader to read frame time. + timeBase <- liftIO $ getTimeBase vs + tsDiffReader <- readTSDiff (readTS timeBase reader) + + -- Texture reader. + let reader' = runMaybeT $ do + (f, t) <- MaybeT tsDiffReader + updateTextureByFrameT texture f + >>= return . flip (,) t + + -- Texture renderer. + render t = do + SDL.copy renderer t Nothing Nothing + SDL.present renderer + + -- New cleanup. + cleanup' = cleanup + >> SDL.destroyTexture texture + >> SDL.destroyRenderer renderer + >> SDL.destroyWindow window + + return (render, reader', cleanup') + + +{- Main. -} + +-- Default configuration. +defaultConfig :: Config +defaultConfig = + Config + { cfgWindowTitle = "VPLay" + , cfgRendererDriver = (-1) -- find driver automatically. + , cfgFmtFFmpeg = avPixFmtRgb24 + , cfgFmtSDL = SDL.RGB24 + } + +-- Runs videoPlayer in Either monad. +runVideoPlayer :: Config -> FilePath -> IO (Either String ()) +runVideoPlayer cfg = runExceptT . videoPlayer cfg . File + +-- Video player with default configuration. +-- Command line argument: path to video file. +main :: IO () +main = getArgs >>= runVideoPlayer defaultConfig . head >> return () diff --git a/ffmpeg-light.cabal b/ffmpeg-light.cabal --- a/ffmpeg-light.cabal +++ b/ffmpeg-light.cabal @@ -1,5 +1,5 @@ name: ffmpeg-light -version: 0.11.3 +version: 0.12.0 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to @@ -15,7 +15,7 @@ > go = do (getFrame, cleanup) <- imageReader "myVideo.mov" > (fmap ImageRGB8 <$> getFrame) <* cleanup . - Tested with FFmpeg 3.1 + Tested with FFmpeg 3.1 - 3.2.4 license: BSD3 license-file: LICENSE @@ -43,6 +43,11 @@ default: False manual: True +flag BuildVPlayDemo + description: Build video player demo executable + default: False + manual: True + library exposed-modules: Codec.FFmpeg, Codec.FFmpeg.Common, @@ -62,7 +67,9 @@ vector >= 0.10.9 && < 0.13, transformers >= 0.4.1 && < 0.6, mtl >= 2.2.1 && < 2.3, - JuicyPixels >= 3.1 && < 3.3 + JuicyPixels >= 3.1 && < 3.3, + bytestring + pkgconfig-depends: libavutil, libavformat, libavcodec, libswscale, libavdevice hs-source-dirs: src include-dirs: src @@ -89,4 +96,15 @@ hs-source-dirs: demo main-is: Raster.hs default-language: Haskell2010 + ghc-options: -Wall -O2 + +executable vplay + if !flag(BuildVPlayDemo) + buildable: False + build-depends: base < 5, mtl, transformers, text, monad-loops, bytestring + if flag(BuildVPlayDemo) + build-depends: ffmpeg-light, sdl2 + hs-source-dirs: demo + main-is: VPlay.hs + default-language: Haskell2010 ghc-options: -Wall -O2 diff --git a/src/Codec/FFmpeg/Common.hsc b/src/Codec/FFmpeg/Common.hsc --- a/src/Codec/FFmpeg/Common.hsc +++ b/src/Codec/FFmpeg/Common.hsc @@ -7,6 +7,7 @@ import Control.Monad.IO.Class import Foreign.C.Types import Foreign.Ptr +import Control.Monad.Trans.Maybe foreign import ccall "avcodec_open2" open_codec :: AVCodecContext -> AVCodec -> Ptr AVDictionary -> IO CInt @@ -47,6 +48,43 @@ -> Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt -> Ptr (Ptr CUChar) -> Ptr CInt -> IO CInt +-- Return size of buffer for image. +foreign import ccall "av_image_get_buffer_size" + av_image_get_buffer_size + -- Pixel format. + :: AVPixelFormat + -- Width. + -> CInt + -- Height. + -> CInt + -- Line size alignment. + -> CInt + -- Size of buffer. + -> IO CInt + +-- Copy image to buffer. +foreign import ccall "av_image_copy_to_buffer" + av_image_copy_to_buffer + -- Destination buffer. + :: Ptr CUChar + -- Destination buffer size. + -> CInt + -- Source image data. + -> Ptr (Ptr CUChar) + -- Source image line size. + -> Ptr CInt + -- Source image pixel format. + -> AVPixelFormat + -- Source image width. + -> CInt + -- Source image height. + -> CInt + -- Source image line size alignment. + -> CInt + -- Number of bytes written to destination. + -> IO CInt + + -- * Utility functions -- | Catch an IOException from an IO action and re-throw it in a @@ -83,3 +121,94 @@ | fmt == avPixFmtRgb8 = Just 1 | fmt == avPixFmtPal8 = Just 1 | otherwise = Nothing + +-- | Return line size alignment. +lineSizeAlign :: CInt -> CInt +lineSizeAlign lineSize + -- Alignment for 512 bit register. + | lineSize `mod` 64 == 0 = 64 + -- Alignment for 256 bit register. + | lineSize `mod` 32 == 0 = 32 + -- Alignment for 128 bit register. + | lineSize `mod` 16 == 0 = 16 + -- Alignment for 64 bit register. + | lineSize `mod` 8 == 0 = 8 + -- Alignment for 32 bit register. + | lineSize `mod` 4 == 0 = 4 + -- Alignment for 16 bit register. + | lineSize `mod` 2 == 0 = 2 + -- Alignment for 8 bit register. + | otherwise = 1 + +-- | Retun 'AVFrame's line size. +frameLineSize :: AVFrame -> IO (Maybe CInt) +frameLineSize frame = do + w <- getWidth frame + fmt <- getPixelFormat frame + return $ + (*w) . fromIntegral <$> avPixelStride fmt + +-- | Transformer version of 'frameLineSize'. +frameLineSizeT :: AVFrame -> MaybeT IO CInt +frameLineSizeT = MaybeT . frameLineSize + +-- Return 'AVFrame's alignment. +frameAlign :: AVFrame -> IO (Maybe CInt) +frameAlign = fmap (fmap lineSizeAlign) . frameLineSize + +-- Transformer version of 'frameAlign'. +frameAlignT :: AVFrame -> MaybeT IO CInt +frameAlignT = MaybeT . frameAlign + + +-- * Wrappers for copying 'AVFrame's image to buffer. + +-- | Return size of buffer for 'AVFrame's image. +frameBufferSize :: AVFrame -> IO (Maybe CInt) +frameBufferSize frame = + runMaybeT $ do + a <- frameAlignT frame + MaybeT $ do + fmt <- getPixelFormat frame + w <- getWidth frame + h <- getHeight frame + Just <$> av_image_get_buffer_size fmt w h a + +-- | Transformer version of 'frameBufferSize'. +frameBufferSizeT :: AVFrame -> MaybeT IO CInt +frameBufferSizeT = MaybeT . frameBufferSize + +-- | Copy 'AVFrame's image to buffer. +-- It is assumed that size of buffer is equal to +-- +-- > bufSize <- fromJust <$> frameBufferSize frame. +frameCopyToBuffer :: AVFrame -> Ptr CUChar -> IO (Maybe CInt) +frameCopyToBuffer frame buffer = + runMaybeT $ do + + a <- frameAlignT frame + s <- frameBufferSizeT frame + + MaybeT $ do + + let imageData = hasData frame + lineSize = hasLineSize frame + + fmt <- getPixelFormat frame + w <- getWidth frame + h <- getHeight frame + + Just <$> + av_image_copy_to_buffer + buffer + s + (castPtr imageData) + lineSize + fmt + w + h + a + +-- | Transformer version of 'frameCopyToBuffer'. +frameCopyToBufferT :: AVFrame -> Ptr CUChar -> MaybeT IO CInt +frameCopyToBufferT frame = MaybeT . frameCopyToBuffer frame diff --git a/src/Codec/FFmpeg/Juicy.hs b/src/Codec/FFmpeg/Juicy.hs --- a/src/Codec/FFmpeg/Juicy.hs +++ b/src/Codec/FFmpeg/Juicy.hs @@ -22,7 +22,30 @@ import Foreign.Marshal.Array (advancePtr, copyArray) import Foreign.Ptr (castPtr, Ptr) import Foreign.Storable (sizeOf) +import Data.Maybe (maybe) + +-- | Convert 'AVFrame' to a 'Vector'. +frameToVector :: AVFrame -> IO (Maybe (V.Vector CUChar)) +frameToVector = runMaybeT . frameToVectorT + + +-- | Convert 'AVFrame' to a 'Vector' with the result in the 'MaybeT' transformer. +frameToVectorT :: AVFrame -> MaybeT IO (V.Vector CUChar) +frameToVectorT frame = do + + bufSize <- fromIntegral <$> frameBufferSizeT frame + + v <- MaybeT $ do + + v <- VM.new bufSize + + VM.unsafeWith v (frameCopyToBuffer frame) + >>= return . maybe Nothing (const (Just v)) + + lift $ V.unsafeFreeze v + + -- | Convert an 'AVFrame' to a 'DynamicImage' with the result in the -- 'MaybeT' transformer. -- @@ -30,56 +53,51 @@ toJuicyT :: AVFrame -> MaybeT IO DynamicImage toJuicyT = MaybeT . toJuicy + -- | Convert an 'AVFrame' to a 'DynamicImage'. toJuicy :: AVFrame -> IO (Maybe DynamicImage) toJuicy frame = runMaybeT $ do - fmt <- lift $ getPixelFormat frame - pixelStride <- MaybeT . return $ avPixelStride fmt + + v <- frameToVectorT frame + MaybeT $ do + w <- fromIntegral <$> getWidth frame h <- fromIntegral <$> getHeight frame - pixels <- castPtr <$> getData frame :: IO (Ptr CUChar) - srcStride <- fromIntegral <$> getLineSize frame - let dstStride = w * pixelStride - v <- VM.new $ h * dstStride - VM.unsafeWith v $ \vptr -> - mapM_ (\(i,o) -> copyArray (advancePtr vptr o) - (advancePtr pixels i) - dstStride) - (map ((srcStride *) &&& (dstStride*)) [0 .. h - 1]) - v' <- V.unsafeFreeze v + let mkImage :: V.Storable (PixelBaseComponent a) => (Image a -> DynamicImage) -> Maybe DynamicImage - mkImage c = Just $ c (Image w h (V.unsafeCast v')) + mkImage c = Just $ c (Image w h (V.unsafeCast v)) + + fmt <- getPixelFormat frame + return $ case () of _ | fmt == avPixFmtRgb24 -> mkImage ImageRGB8 | fmt == avPixFmtGray8 -> mkImage ImageY8 | fmt == avPixFmtGray16 -> mkImage ImageY16 | otherwise -> Nothing + -- | Convert an 'AVFrame' to an 'Image'. toJuicyImage :: forall p. JuicyPixelFormat p => AVFrame -> IO (Maybe (Image p)) -toJuicyImage frame = - do fmt <- getPixelFormat frame - if fmt /= juicyPixelFormat ([] :: [p]) - then return Nothing - else do w <- fromIntegral <$> getWidth frame - h <- fromIntegral <$> getHeight frame - pixels <- castPtr <$> getData frame :: IO (Ptr CUChar) - srcStride <- fromIntegral <$> getLineSize frame - let dstStride = w * juicyPixelStride ([]::[p]) - v <- VM.new $ h * dstStride - VM.unsafeWith v $ \vptr -> - mapM_ (\(i,o) -> copyArray (advancePtr vptr o) - (advancePtr pixels i) - dstStride) - (map ((srcStride *) &&& (dstStride*)) [0 .. h - 1]) - Just . Image w h . V.unsafeCast <$> V.unsafeFreeze v +toJuicyImage frame = runMaybeT $ do + + fmt <- lift $ getPixelFormat frame + guard (fmt == juicyPixelFormat ([] :: [p])) + + MaybeT $ do + + w <- fromIntegral <$> getWidth frame + h <- fromIntegral <$> getHeight frame + + fmap (Image w h . V.unsafeCast) <$> frameToVector frame + -- | Save an 'AVFrame' to a PNG file on disk assuming the frame could -- be converted to a 'DynamicImage' using 'toJuicy'. saveJuicy :: FilePath -> AVFrame -> IO () saveJuicy name = toJuicy >=> traverse_ (savePngImage name) + -- | Mapping of @JuicyPixels@ pixel types to FFmpeg pixel formats. class Pixel a => JuicyPixelFormat a where