diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,67 @@ +import Codec.FFmpeg +import Codec.Picture +import Control.Applicative +import Control.Monad.Error +import Control.Monad.Trans.Maybe +import qualified Data.Vector.Storable as V +import System.Environment + +-- The example used in the README +firstFrame :: IO (Maybe DynamicImage) +firstFrame = do (getFrame, cleanup) <- frameReaderT "myVideo.mov" + (runMaybeT $ getFrame >>= toJuicyT) <* cleanup + +-- | Generate a video that pulses from light to dark. +pulseVid :: IO () +pulseVid = + do boom <- frameWriter (defaultParams sz sz) "pulse.mov" + let go :: Int -> Int -> Int -> IO () + go 600 _ _ = boom Nothing + go n d i = do boom (Just $ V.replicate (fromIntegral $ sz*sz*3) + (fromIntegral i)) + let i' = i + d + if i' < 100 + then go (n+1) 1 101 + else if i' > 255 + then go (n+1) (-1) 254 + else go (n+1) d i' + + go 0 (-1) 255 + where sz = 64 + +testEncode :: IO () +testEncode = initFFmpeg >> pulseVid >> putStrLn "All done!" + +testDecode :: FilePath -> IO () +testDecode vidFile = + do initFFmpeg + (getFrame, cleanup) <- frameReaderTime vidFile + frame1 <- getFrame + case frame1 of + Just (avf,ts) -> do putStrLn $ "Frame at "++show ts + saveJuicy "frame1.png" avf + Nothing -> putStrLn "No frame for me :(" + replicateM_ 299 getFrame + frame2 <- getFrame + case frame2 of + Just (avf,ts) -> do putStrLn $ "Frame at "++show ts + saveJuicy "frame2.png" avf + Nothing -> putStrLn "No frame for me :(" + cleanup + putStrLn "All done!" + +main :: IO () +main = do args <- getArgs + case args of + [] -> testEncode + [vidFile] -> testDecode vidFile + _ -> error usage + where usage = + unlines [ "Usage: demo [videoFile]" + , " If no argument is given, a test video named " + , " pulse.mov is generated." + , "" + , " If a file name is given, then two frames are " + , " extracted: the first frame, and the 301st." + , " These are saved to frame1.png and frame2.png" ] + 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.1.0.1 +version: 0.2 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to @@ -10,11 +10,11 @@ > import Codec.FFmpeg > import Codec.Picture > import Control.Applicative - > import Data.Traversable + > import Control.Monad.Trans.Maybe > > go :: IO (Maybe DynamicImage) - > go = do (getFrame, cleanup) <- frameReader "myVideo.mov" - > (getFrame >>= traverse juicyRGB) <* cleanup + > go = do (getFrame, cleanup) <- frameReaderT "myVideo.mov" + > (runMaybeT $ getFrame >>= toJuicyT) <* cleanup . Tested on OS X 10.9.2 with 2.2.1 installed via . @@ -26,13 +26,17 @@ copyright: Copyright (C) 2014 Anthony Cowley category: Codec build-type: Simple -extra-source-files: src/hscMacros.h +extra-source-files: src/hscMacros.h, src/nameCompat.h cabal-version: >=1.10 source-repository head type: git location: http://github.com/acowley/ffmpeg-light.git +flag BuildDemo + description: Build demo executable + default: False + library exposed-modules: Codec.FFmpeg, Codec.FFmpeg.Common, @@ -40,6 +44,7 @@ Codec.FFmpeg.Encode, Codec.FFmpeg.Enums, Codec.FFmpeg.Juicy, + Codec.FFmpeg.Scaler, Codec.FFmpeg.Types, Codec.FFmpeg.Internal.Debug build-tools: hsc2hs @@ -53,3 +58,14 @@ include-dirs: src default-language: Haskell2010 ghc-options: -Wall + +executable demo + if !flag(BuildDemo) + buildable: False + build-depends: base < 5, vector, mtl, transformers, + ffmpeg-light, JuicyPixels + hs-source-dirs: demo + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -Wall + diff --git a/src/Codec/FFmpeg.hs b/src/Codec/FFmpeg.hs --- a/src/Codec/FFmpeg.hs +++ b/src/Codec/FFmpeg.hs @@ -4,11 +4,12 @@ module Codec.FFmpeg (-- * Initialization initFFmpeg, -- * Decoding - frameReader, frameReaderTime, + frameReader, frameReaderT, + frameReaderTime, frameReaderTimeT, -- * Encoding EncodingParams(..), defaultParams, frameWriter, -- * JuicyPixels interop - juicyRGB, saveJuicyRGB, + toJuicy, toJuicyT, saveJuicy, -- * Types and Enums module Codec.FFmpeg.Types, module Codec.FFmpeg.Enums diff --git a/src/Codec/FFmpeg/Decode.hs b/src/Codec/FFmpeg/Decode.hs --- a/src/Codec/FFmpeg/Decode.hs +++ b/src/Codec/FFmpeg/Decode.hs @@ -5,11 +5,14 @@ module Codec.FFmpeg.Decode where import Codec.FFmpeg.Common import Codec.FFmpeg.Enums +import Codec.FFmpeg.Scaler import Codec.FFmpeg.Types import Control.Applicative +import Control.Arrow (first) import Control.Monad (when) import Control.Monad.Error.Class import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe import Foreign.C.String import Foreign.C.Types import Foreign.Marshal.Alloc (alloca, free, mallocBytes) @@ -136,6 +139,13 @@ _ <- openCodec ctx cod prepareReader inputContext vidStreamIndex ctx +-- | Read RGB frames with the result in the 'MaybeT' transformer. +-- +-- > frameReaderT = fmap (first MaybeT) . frameReader +frameReaderT :: (Functor m, MonadIO m, Error e, MonadError e m) + => FilePath -> m (MaybeT IO AVFrame, IO ()) +frameReaderT = fmap (first MaybeT) . frameReader + -- | Read time stamped RGB frames from a video stream. Time is given -- in seconds from the start of the stream. frameReaderTime :: (MonadIO m, Error e, MonadError e m) @@ -158,6 +168,14 @@ return $ Just (f, t) return (readTS, cleanup) +-- | Read time stamped RGB frames with the result in the 'MaybeT' +-- transformer. +-- +-- > frameReaderT = fmap (first MaybeT) . frameReader +frameReaderTimeT :: (Functor m, MonadIO m, Error e, MonadError e m) + => FilePath -> m (MaybeT IO (AVFrame, Double), IO ()) +frameReaderTimeT = fmap (first MaybeT) . frameReaderTime + -- | Construct an action that gets the next available frame, and an -- action to release all resources associated with this video stream. prepareReader :: (MonadIO m, Error e, MonadError e m) @@ -178,11 +196,8 @@ frame_get_buffer_check fRgb 32 - sws <- sws_getCachedContext (SwsContext nullPtr) - w h fmt - w h avPixFmtRgb24 - swsBilinear - nullPtr nullPtr nullPtr + sws <- swsInit (ImageInfo w h fmt) (ImageInfo w h avPixFmtRgb24) + swsBilinear pkt <- AVPacket <$> mallocBytes packetSize let cleanup = do with fRgb av_frame_free @@ -208,12 +223,8 @@ -- (#poke AVPacket, size) pkt (0::CInt) -- decode_video codCtx fRaw fin2 pkt -- peek fin2 - let frameData = castPtr $ hasData fRaw - lnSize = hasLineSize fRaw - rgbData = castPtr $ hasData fRgb - rgbLnSize = hasLineSize fRgb - _ <- sws_scale sws frameData lnSize 0 h rgbData rgbLnSize + _ <- swsScale sws fRaw fRgb -- Copy the raw frame's timestamp to the RGB frame getPktPts fRaw >>= setPts fRgb diff --git a/src/Codec/FFmpeg/Encode.hs b/src/Codec/FFmpeg/Encode.hs --- a/src/Codec/FFmpeg/Encode.hs +++ b/src/Codec/FFmpeg/Encode.hs @@ -5,7 +5,9 @@ module Codec.FFmpeg.Encode where import Codec.FFmpeg.Common import Codec.FFmpeg.Enums +import Codec.FFmpeg.Scaler import Codec.FFmpeg.Types +import Codec.Picture import Control.Applicative import Control.Monad (when) import Control.Monad.Error.Class @@ -16,7 +18,6 @@ import Foreign.C.String import Foreign.C.Types import Foreign.Marshal.Alloc -import Foreign.Marshal.Array import Foreign.Marshal.Utils import Foreign.Ptr @@ -134,10 +135,10 @@ -- | Initialize a temporary YUV frame of the same resolution as the -- output video stream. We well convert RGB frames using this frame as -- a destination before encoding the video frame. -initTempYuv :: EncodingParams -> IO AVFrame -initTempYuv ep = do +initTempFrame :: EncodingParams -> AVPixelFormat -> IO AVFrame +initTempFrame ep fmt = do yuv <- frame_alloc_check - setPixelFormat yuv avPixFmtYuv420p + setPixelFormat yuv fmt setWidth yuv (epWidth ep) setHeight yuv (epHeight ep) setPts yuv 0 @@ -211,12 +212,13 @@ oc <- allocOutputContext fname (st,ctx) <- initStream ep oc - yuv <- initTempYuv ep + dstFmt <- getPixelFormat ctx + dstFrame <- initTempFrame ep dstFmt - sws <- sws_getCachedContext (SwsContext nullPtr) - (epWidth ep) (epHeight ep) avPixFmtRgb24 - (epWidth ep) (epHeight ep) avPixFmtYuv420p - swsBilinear nullPtr nullPtr nullPtr + -- Initialize the scaler that we use to convert RGB -> YUV + sws <- swsInit (ImageInfo (epWidth ep) (epHeight ep) avPixFmtRgb24) + (ImageInfo (epWidth ep) (epHeight ep) dstFmt) + swsBilinear pkt <- AVPacket <$> mallocBytes packetSize @@ -227,8 +229,10 @@ tb <- getTimeBase st codecTB <- getCodecContext st >>= getTimeBase let frameTime = av_rescale_q 1 codecTB tb - - let resetPacket = do init_packet pkt + mkImage :: Vector CUChar -> Image PixelRGB8 + mkImage = let [w,h] = map fromIntegral [epWidth ep, epHeight ep] + in Image w h . V.unsafeCast + resetPacket = do init_packet pkt setData pkt nullPtr setSize pkt 0 writePacket = do setStreamIndex pkt stIndex @@ -240,21 +244,14 @@ then writePacket >> go Nothing else do write_trailer_check oc _ <- codec_close ctx - with yuv av_frame_free + with dstFrame av_frame_free avio_close_check oc avformat_free_context oc go (Just pixels) = do resetPacket - let yuvData = castPtr $ hasData yuv - yuvStride = hasLineSize yuv - - _ <- V.unsafeWith pixels $ \pixelPtr -> - withArray (pixelPtr : replicate 7 nullPtr) $ \srcArray -> - withArray (epWidth ep * 3 : replicate 7 0) $ \strides -> - sws_scale sws srcArray strides 0 (epHeight ep) - yuvData yuvStride + _ <- swsScale sws (mkImage pixels) dstFrame - getPts yuv >>= setPts yuv . (+ frameTime) - encode_video_check ctx pkt (Just yuv) >>= flip when writePacket + getPts dstFrame >>= setPts dstFrame . (+ frameTime) + encode_video_check ctx pkt (Just dstFrame) >>= flip when writePacket return go diff --git a/src/Codec/FFmpeg/Enums.hsc b/src/Codec/FFmpeg/Enums.hsc --- a/src/Codec/FFmpeg/Enums.hsc +++ b/src/Codec/FFmpeg/Enums.hsc @@ -7,8 +7,18 @@ #include #include #include +#include +#include #include +#ifndef PIX_FMT_RGBA64 +-- WARNING: Fragile! This pixel format is not defined in older +-- versions. Note that many FFI calls will fail at runtime with older +-- versions, so all this does is let us the haskell code. +#warning "This version of libav/ffmpeg is too old. It is not likely to work." +#include "nameCompat.h" +#endif + newtype AVMediaType = AVMediaType CInt deriving (Eq, Storable) #enum AVMediaType,AVMediaType \ , AVMEDIA_TYPE_VIDEO\ @@ -29,6 +39,7 @@ , AV_PIX_FMT_GRAY8\ , AV_PIX_FMT_GRAY16\ , AV_PIX_FMT_GRAY8A\ + , AV_PIX_FMT_PAL8\ , AV_PIX_FMT_RGB565\ , AV_PIX_FMT_RGB555\ , AV_PIX_FMT_YUV420P\ @@ -149,6 +160,10 @@ newtype AVRoundMode = AVRoundMode CInt deriving (Eq, Storable) #enum AVRoundMode, AVRoundMode \ + , AV_ROUND_ZERO\ + , AV_ROUND_INF\ + , AV_ROUND_DOWN\ + , AV_ROUND_UP\ , AV_ROUND_NEAR_INF\ , AV_ROUND_PASS_MINMAX 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} -- | Convert between FFmpeg frames and JuicyPixels images. module Codec.FFmpeg.Juicy where import Codec.Picture @@ -6,15 +7,24 @@ import Control.Applicative import Control.Arrow ((&&&)) import Control.Monad (when, (>=>)) +import Control.Monad.Trans.Maybe +import Data.Foldable (traverse_) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM import Foreign.C.Types import Foreign.Marshal.Array (advancePtr, copyArray) import Foreign.Ptr (castPtr, Ptr) --- | Convert an RGB24 'AVFrame' to a 'DynamicImage'. -juicyRGB :: AVFrame -> IO DynamicImage -juicyRGB frame = do +-- | Convert an 'AVFrame' to a 'DynamicImage' with the result in the +-- 'MaybeT' transformer. +-- +-- > toJuicyT = MaybeT . toJuicy +toJuicyT :: AVFrame -> MaybeT IO DynamicImage +toJuicyT = MaybeT . toJuicy + +-- | Convert an 'AVFrame' to a 'DynamicImage'. +toJuicy :: AVFrame -> IO (Maybe DynamicImage) +toJuicy frame = do fmt <- getPixelFormat frame when (fmt /= avPixFmtRgb24) (putStrLn "Not RGB24?!") @@ -30,8 +40,17 @@ (w * 3)) (map ((srcStride *) &&& (dstStride*)) [0 .. h - 1]) v' <- V.unsafeFreeze v - return $ ImageRGB8 (Image w h (V.unsafeCast v')) + let mkImage :: V.Storable (PixelBaseComponent a) + => (Image a -> DynamicImage) -> Maybe DynamicImage + mkImage c = Just $ c (Image w h (V.unsafeCast v')) + return $ + case () of + _ | fmt == avPixFmtRgb24 -> mkImage ImageRGB8 + | fmt == avPixFmtGray8 -> mkImage ImageY8 + | fmt == avPixFmtGray16 -> mkImage ImageY16 + | otherwise -> Nothing --- | Save an RGB24 'AVFrame' to a PNG file on disk. -saveJuicyRGB :: FilePath -> AVFrame -> IO () -saveJuicyRGB name = juicyRGB >=> savePngImage name +-- | 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) diff --git a/src/Codec/FFmpeg/Scaler.hs b/src/Codec/FFmpeg/Scaler.hs new file mode 100644 --- /dev/null +++ b/src/Codec/FFmpeg/Scaler.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +module Codec.FFmpeg.Scaler where +import Codec.FFmpeg.Common +import Codec.FFmpeg.Enums +import Codec.FFmpeg.Types +import Codec.Picture +import qualified Data.Vector.Storable as V +import Foreign.C.Types +import Foreign.Marshal.Array (withArray) +import Foreign.Ptr (castPtr, nullPtr, Ptr) +import Foreign.Storable (Storable(sizeOf)) + +data ImageInfo = ImageInfo { imgWidth :: CInt + , imgHeight :: CInt + , imgFormat :: AVPixelFormat } + +swsInit :: ImageInfo -> ImageInfo -> SwsAlgorithm -> IO SwsContext +swsInit = swsReset (SwsContext nullPtr) + +-- | Obtain a context for converting the source to destination +-- format. If the given context is already configured for the required +-- conversion, it is returned. Otherwise, the given context is freed +-- and a new, configured context is returned. +swsReset :: SwsContext -> ImageInfo -> ImageInfo -> SwsAlgorithm + -> IO SwsContext +swsReset ctx src dst alg = sws_getCachedContext ctx + srcW srcH srcFmt + dstW dstH dstFmt + alg nullPtr nullPtr nullPtr + where ImageInfo srcW srcH srcFmt = src + ImageInfo dstW dstH dstFmt = dst + +-- | A common interface required of arguments to 'swsScale' (a higher +-- level wrapper for the 'sws_scale' function from @libswscale@). +class SwsCompatible a where + swsPlanes :: a -> (Ptr (Ptr CUChar) -> IO r) -> IO r + swsStrides :: a -> (Ptr CInt -> IO r) -> IO r + sliceHeight :: a -> (CInt -> IO r) -> IO r + +instance SwsCompatible AVFrame where + swsPlanes frame k = k (castPtr $ hasData frame) + swsStrides frame k = k (hasLineSize frame) + sliceHeight frame k = getHeight frame >>= k + +instance (Pixel a, Storable (PixelBaseComponent a)) + => SwsCompatible (Image a) where + swsPlanes img k = V.unsafeWith (imageData img) $ \ptr -> + withArray (castPtr ptr : replicate 7 nullPtr) k + swsStrides img k = withArray (stride : replicate 7 0) k + where sz = sizeOf (undefined::PixelBaseComponent a) * + componentCount (undefined :: a) + stride = fromIntegral $ imageWidth img * sz + sliceHeight img k = k (fromIntegral $ imageHeight img) + +-- | Supplies a continuation with all components provided by the +-- 'SwsCompatible' class. +withSws :: SwsCompatible a + => a -> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO r) -> IO r +withSws img k = swsPlanes img $ \planes -> + swsStrides img $ \strides -> + sliceHeight img $ \height -> + k planes strides height + +-- | @swsScale ctx src dst@ scales the entire @src@ image to @dst@ +-- using the previously initialized @ctx@. +swsScale :: (SwsCompatible src, SwsCompatible dst) + => SwsContext -> src -> dst -> IO CInt +swsScale ctx src dst = withSws src $ \srcPlanes srcStrides srcHeight -> + withSws dst $ \dstPlanes dstStrides _ -> + sws_scale ctx srcPlanes srcStrides + 0 srcHeight + dstPlanes dstStrides diff --git a/src/nameCompat.h b/src/nameCompat.h new file mode 100644 --- /dev/null +++ b/src/nameCompat.h @@ -0,0 +1,56 @@ +/* Older versions of libav (and perhaps ffmpeg) used a different + naming scheme for constants. Since distributions like Ubuntu 12.04 + are locked down with these old versions, we hack in support for the + newer constant names. */ + +#define AV_PIX_FMT_RGB24 PIX_FMT_RGB24 +#define AV_PIX_FMT_Y400A PIX_FMT_Y400A +#define AV_PIX_FMT_RGB32 PIX_FMT_RGB32 +#define AV_PIX_FMT_RGB32_1 PIX_FMT_RGB32_1 +#define AV_PIX_FMT_BGR32 PIX_FMT_BGR32 +#define AV_PIX_FMT_BGR32_1 PIX_FMT_BGR32_1 +#define AV_PIX_FMT_GRAY8 PIX_FMT_GRAY8 +#define AV_PIX_FMT_GRAY16 PIX_FMT_GRAY16 +#define AV_PIX_FMT_GRAY8A -1 +#define AV_PIX_FMT_RGB565 PIX_FMT_RGB565 +#define AV_PIX_FMT_RGB555 PIX_FMT_RGB555 +#define AV_PIX_FMT_YUV420P PIX_FMT_YUV420P +#define AV_PIX_FMT_YUV420P9 PIX_FMT_YUV420P9 +#define AV_PIX_FMT_YUV420P10 PIX_FMT_YUV420P10 +#define AV_PIX_FMT_YUV420P12 -1 +#define AV_PIX_FMT_YUV422P12 -1 +#define AV_PIX_FMT_YUV444P12 -1 +#define AV_PIX_FMT_YUV420P14 -1 +#define AV_PIX_FMT_YUV422P14 -1 +#define AV_PIX_FMT_YUV444P14 -1 +#define AV_PIX_FMT_YUV420P16 PIX_FMT_YUV420P16 +#define AV_PIX_FMT_YUV422P16 PIX_FMT_YUV422P16 +#define AV_PIX_FMT_YUV444P16 PIX_FMT_YUV444P16 +#define AV_PIX_FMT_RGBA64 -1 +#define AV_PIX_FMT_BGRA64 -1 + +#define AV_CODEC_ID_H264 CODEC_ID_H264 +#define AV_CODEC_ID_THEORA CODEC_ID_THEORA +#define AV_CODEC_ID_MPEG4 CODEC_ID_MPEG4 +#define AV_CODEC_ID_MPEG2VIDEO CODEC_ID_MPEG2VIDEO +#define AV_CODEC_ID_GIF CODEC_ID_GIF +#define AV_CODEC_ID_AAC CODEC_ID_AAC +#define AV_CODEC_ID_MP3 CODEC_ID_MP3 +#define AV_CODEC_ID_DTS CODEC_ID_DTS + +#define FF_PROFILE_AAC_HE -1 +#define FF_PROFILE_AAC_HE_V2 -1 +#define FF_PROFILE_AAC_LD -1 +#define FF_PROFILE_AAC_ELD -1 +#define FF_PROFILE_MPEG2_AAC_LOW -1 +#define FF_PROFILE_MPEG2_AAC_HE -1 + +#define AVIO_FLAG_DIRECT -1 + +#define AV_ROUND_PASS_MINMAX -1 + +#define CODEC_FLAG_UNALIGNED -1 +#define CODEC_FLAG_OUTPUT_CORRUPT -1 + +#define AVFMT_ALLOW_FLUSH -1 +#define AVFMT_TS_NONSTRICT -1