diff --git a/demo/Raster.hs b/demo/Raster.hs new file mode 100644 --- /dev/null +++ b/demo/Raster.hs @@ -0,0 +1,2 @@ +module Main where +import Codec.FFmpeg 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.2.0.1 +version: 0.3 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to @@ -34,9 +34,13 @@ location: http://github.com/acowley/ffmpeg-light.git flag BuildDemo - description: Build demo executable + description: Build simple demo executable default: False +flag BuildRasterDemo + description: Build Rasterific demo executable + default: False + library exposed-modules: Codec.FFmpeg, Codec.FFmpeg.Common, @@ -48,7 +52,7 @@ Codec.FFmpeg.Types, Codec.FFmpeg.Internal.Debug build-tools: hsc2hs - build-depends: base >=4.6 && < 5, + build-depends: base >=4.6 && < 5, vector >= 0.10.9 && < 0.11, transformers >= 0.3 && < 0.4, mtl >= 2.1.3 && < 2.2, @@ -68,4 +72,13 @@ main-is: Main.hs default-language: Haskell2010 ghc-options: -Wall - + +executable raster + if !flag(BuildRasterDemo) + buildable: False + build-depends: base < 5, vector, mtl, transformers, + ffmpeg-light, JuicyPixels, Rasterific + hs-source-dirs: demo + main-is: Raster.hs + default-language: Haskell2010 + ghc-options: -Wall 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 @@ -9,7 +9,7 @@ import Codec.FFmpeg.Types import Codec.Picture import Control.Applicative -import Control.Monad (when) +import Control.Monad (when, void) import Control.Monad.Error.Class import Data.Bits import Data.Maybe (fromMaybe) @@ -79,20 +79,38 @@ foreign import ccall "avformat_free_context" avformat_free_context :: AVFormatContext -> IO () +foreign import ccall "av_image_fill_arrays" + av_image_fill_arrays :: Ptr (Ptr CUChar) -> Ptr CInt -> Ptr CUChar + -> AVPixelFormat -> CInt -> CInt -> CInt -> IO CInt + -- * FFmpeg Encoding Interface -- | Minimal parameters describing the desired video output. data EncodingParams = EncodingParams { epWidth :: CInt , epHeight :: CInt , epFps :: Int - , epCodec :: AVCodecID + , epCodec :: Maybe AVCodecID + -- ^ If 'Nothing', then the codec + -- is inferred from the output + -- file name. If 'Just', then + -- this codec is manually chosen. , epPreset :: String } -- | Use default parameters for a video of the given width and --- height. This produces an h264 encoded stream. +-- height, forcing the choice of the h264 encoder. +defaultH264 :: CInt -> CInt -> EncodingParams +defaultH264 w h = EncodingParams w h 30 (Just avCodecIdH264) "medium" + +-- | Use default parameters for a video of the given width and +-- height. The output format is determined by the output file name. defaultParams :: CInt -> CInt -> EncodingParams -defaultParams w h = EncodingParams w h 30 avCodecIdH264 "medium" +defaultParams w h = EncodingParams w h 30 Nothing "" +-- | Determine if the bitwise intersection of two values is non-zero. +checkFlag :: Bits a => a -> a -> Bool +checkFlag flg = \x -> (flg .&. x) /= allZeroBits + where allZeroBits = clearBit (bit 0) 0 + -- | Find and initialize the requested encoder, and add a video stream -- to the output container. initStream :: EncodingParams -> AVFormatContext -> IO (AVStream, AVCodecContext) @@ -100,9 +118,12 @@ | (epWidth ep `rem` 2, epHeight ep `rem` 2) /= (0,0) = throwError $ strMsg "Video dimensions must be multiples of two" initStream ep oc = do - cod <- avcodec_find_encoder (epCodec ep) + -- Use the codec suggested by the output format, or override with + -- the user's choice. + codec <- maybe (getOutputFormat oc >>= getVideoCodecID) return (epCodec ep) + cod <- avcodec_find_encoder codec when (getPtr cod == nullPtr) - (throwError $ strMsg "Couldn't find H264 encoder") + (errMsg "Couldn't find encoder") st <- avformat_new_stream oc cod getNumStreams oc >>= setId st . subtract 1 @@ -112,11 +133,15 @@ setHeight ctx (epHeight ep) let framePeriod = AVRational 1 (fromIntegral $ epFps ep) setTimeBase ctx framePeriod - setPixelFormat ctx avPixFmtYuv420p - + setPixelFormat ctx $ case () of + _ | codec == avCodecIdRawvideo -> avPixFmtRgb24 + | codec == avCodecIdGif -> avPixFmtPal8 + | otherwise -> avPixFmtYuv420p + -- Some formats want stream headers to be separate - outputFlags <- getOutputFormat oc >>= getFormatFlags - when (outputFlags .&. avfmtGlobalheader /= clearBit (bit 0) 0) $ + needsHeader <- checkFlag avfmtGlobalheader <$> + (getOutputFormat oc >>= getFormatFlags) + when needsHeader $ getCodecFlags ctx >>= setCodecFlags ctx . (.|. codecFlagGlobalHeader) -- _ <- withCString "vprofile" $ \kStr -> @@ -130,6 +155,7 @@ rOpen <- open_codec ctx cod nullPtr when (rOpen < 0) (throwError $ strMsg "Couldn't open codec") + return (st, ctx) -- | Initialize a temporary YUV frame of the same resolution as the @@ -149,15 +175,16 @@ -- file name. allocOutputContext :: FilePath -> IO AVFormatContext allocOutputContext fname = do - oc <- alloca $ \ocTmp -> - withCString fname $ \fname' -> do - r <- avformat_alloc_output_context ocTmp (AVOutputFormat nullPtr) - nullPtr fname' - when (r < 0) - (throwError $ strMsg "Couldn't allocate output format context") - peek ocTmp + oc <- alloca $ \ocTmp -> do + r <- withCString fname $ \fname' -> + avformat_alloc_output_context + ocTmp (AVOutputFormat nullPtr) + nullPtr fname' + when (r < 0) + (errMsg "Couldn't allocate output format context") + peek ocTmp when (getPtr oc == nullPtr) - (throwError $ strMsg "Couldn't allocate output AVFormatContext") + (errMsg "Couldn't allocate output AVFormatContext") return oc -- | Open the given file for writing. @@ -215,10 +242,14 @@ dstFmt <- getPixelFormat ctx dstFrame <- initTempFrame ep dstFmt - -- 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 + -- Initialize the scaler that we use to convert RGB -> dstFmt + -- Note that libswscaler does not support Pal8 as an output format. + sws <- if dstFmt /= avPixFmtPal8 + then Just <$> + swsInit (ImageInfo (epWidth ep) (epHeight ep) avPixFmtRgb24) + (ImageInfo (epWidth ep) (epHeight ep) dstFmt) + swsBilinear + else return Nothing pkt <- AVPacket <$> mallocBytes packetSize @@ -228,6 +259,8 @@ tb <- getTimeBase st codecTB <- getCodecContext st >>= getTimeBase + isRaw <- checkFlag avfmtRawpicture <$> (getOutputFormat oc >>= getFormatFlags) + let frameTime = av_rescale_q 1 codecTB tb mkImage :: Vector CUChar -> Image PixelRGB8 mkImage = let [w,h] = map fromIntegral [epWidth ep, epHeight ep] @@ -237,21 +270,42 @@ setSize pkt 0 writePacket = do setStreamIndex pkt stIndex write_frame_check oc pkt - go Nothing = do - resetPacket - goOn <- encode_video_check ctx pkt Nothing - if goOn - then writePacket >> go Nothing - else do write_trailer_check oc - _ <- codec_close ctx - with dstFrame av_frame_free - avio_close_check oc - avformat_free_context oc - - go (Just pixels) = do - resetPacket - _ <- swsScale sws (mkImage pixels) dstFrame - - getPts dstFrame >>= setPts dstFrame . (+ frameTime) - encode_video_check ctx pkt (Just dstFrame) >>= flip when writePacket + copyDstData pixels = + void . V.unsafeWith pixels $ \ptr -> + av_image_fill_arrays (castPtr $ hasData dstFrame) + (hasLineSize dstFrame) + (castPtr ptr) + dstFmt + (epWidth ep) + (epHeight ep) + 1 + scaleToDst sws' pixels = void $ swsScale sws' (mkImage pixels) dstFrame + fillDst = maybe copyDstData scaleToDst sws + addRaw Nothing = return () + addRaw (Just pixels) = + do resetPacket + getPacketFlags pkt >>= setPacketFlags pkt . (.|. avPktFlagKey) + setSize pkt (fromIntegral $ V.length pixels) + getPts dstFrame >>= setPts dstFrame . (+ frameTime) + getPts dstFrame >>= setPts pkt + getPts dstFrame >>= setDts pkt + V.unsafeWith pixels $ \ptr -> do + setData pkt (castPtr ptr) + writePacket + addEncoded Nothing = do resetPacket + encode_video_check ctx pkt Nothing >>= + flip when (writePacket >> addEncoded Nothing) + addEncoded (Just pixels) = + do resetPacket + fillDst pixels + getPts dstFrame >>= setPts dstFrame . (+ frameTime) + encode_video_check ctx pkt (Just dstFrame) >>= flip when writePacket + addFrame = if isRaw then addRaw else addEncoded + go Nothing = do addFrame Nothing + write_trailer_check oc + _ <- codec_close ctx + with dstFrame av_frame_free + avio_close_check oc + avformat_free_context oc + go (Just pixels) = addFrame (Just pixels) 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 @@ -30,12 +30,17 @@ newtype AVPixelFormat = AVPixelFormat CInt deriving (Eq, Storable) #enum AVPixelFormat,AVPixelFormat \ + , AV_PIX_FMT_NONE\ , AV_PIX_FMT_RGB24\ , AV_PIX_FMT_Y400A\ , AV_PIX_FMT_RGB32\ , AV_PIX_FMT_RGB32_1\ , AV_PIX_FMT_BGR32\ , AV_PIX_FMT_BGR32_1\ + , AV_PIX_FMT_RGB8\ + , AV_PIX_FMT_BGR8\ + , AV_PIX_FMT_RGB4_BYTE\ + , AV_PIX_FMT_BGR4_BYTE\ , AV_PIX_FMT_GRAY8\ , AV_PIX_FMT_GRAY16\ , AV_PIX_FMT_GRAY8A\ @@ -69,9 +74,12 @@ newtype AVCodecID = AVCodecID CInt deriving (Eq, Show, Storable) #enum AVCodecID,AVCodecID \ , AV_CODEC_ID_H264\ + , AV_CODEC_ID_HEVC\ , AV_CODEC_ID_THEORA\ + , AV_CODEC_ID_VC1\ , AV_CODEC_ID_MPEG4\ , AV_CODEC_ID_MPEG2VIDEO\ + , AV_CODEC_ID_RAWVIDEO\ , AV_CODEC_ID_GIF\ , AV_CODEC_ID_AAC\ , AV_CODEC_ID_MP3\ @@ -205,3 +213,8 @@ , AVFMT_NOSTREAMS\ , AVFMT_ALLOW_FLUSH\ , AVFMT_TS_NONSTRICT + +newtype PacketFlag = PacketFlag CInt deriving (Eq, Bits, Storable) +#enum PacketFlag, PacketFlag \ + , AV_PKT_FLAG_KEY\ + , AV_PKT_FLAG_CORRUPT diff --git a/src/Codec/FFmpeg/Internal/Debug.hsc b/src/Codec/FFmpeg/Internal/Debug.hsc --- a/src/Codec/FFmpeg/Internal/Debug.hsc +++ b/src/Codec/FFmpeg/Internal/Debug.hsc @@ -1,8 +1,12 @@ -- | Helpers for dumping information about codecs to stdout. module Codec.FFmpeg.Internal.Debug where +import Codec.FFmpeg.Enums import Codec.FFmpeg.Types +import Control.Monad (when, (>=>)) import Foreign.C.String import Foreign.C.Types +import Foreign.Marshal.Array (advancePtr) +import Foreign.Ptr (nullPtr) import Foreign.Storable #include @@ -39,3 +43,29 @@ (#peek AVCodecContext, me_range) p >>= si "me_range" putStrLn "" where si msg = putStrLn . ((msg++" = ")++) . show :: CInt -> IO () + +foreign import ccall "av_get_pix_fmt_name" + av_get_pix_fmt_name :: AVPixelFormat -> IO CString + +pixFmtName :: AVPixelFormat -> IO String +pixFmtName = av_get_pix_fmt_name >=> peekCString + +-- | Print all pixel formats supported by a given 'AVCodec'. +debugPixelFormats :: AVCodec -> IO () +debugPixelFormats cod = putStrLn "Supported pixel formats:" >> + getPixelFormats cod >>= go 0 + where go i fmts + = let ptr = advancePtr fmts i + in when (ptr /= nullPtr) $ do + fmt <- peek ptr + when (fmt /= avPixFmtNone) $ do + av_get_pix_fmt_name fmt >>= peekCString >>= + putStrLn . (" " ++) + go (i+1) fmts + +foreign import ccall "avcodec_get_name" + avcodec_get_name :: AVCodecID -> IO CString + +-- | Get the name of a codec. +debugCodecName :: AVCodecID -> IO String +debugCodecName = avcodec_get_name >=> peekCString diff --git a/src/Codec/FFmpeg/Types.hsc b/src/Codec/FFmpeg/Types.hsc --- a/src/Codec/FFmpeg/Types.hsc +++ b/src/Codec/FFmpeg/Types.hsc @@ -65,10 +65,12 @@ newtype AVCodec = AVCodec (Ptr ()) deriving (Storable, HasPtr) #mkField LongName, CString #mkField Name, CString +#mkField PixelFormats, (Ptr AVPixelFormat) #hasField AVCodec, LongName, long_name #hasField AVCodec, Name, name #hasField AVCodec, CodecID, id +#hasField AVCodec, PixelFormats, pix_fmts newtype AVDictionary = AVDictionary (Ptr ()) deriving (Storable, HasPtr) newtype AVFrame = AVFrame (Ptr ()) deriving (Storable, HasPtr) @@ -85,24 +87,36 @@ #hasField AVFrame, Data, data newtype AVPicture = AVPicture (Ptr ()) deriving (Storable, HasPtr) +#hasField AVPicture, Data, data + newtype SwsContext = SwsContext (Ptr ()) deriving (Storable, HasPtr) newtype AVOutputFormat = AVOutputFormat (Ptr ()) deriving (Storable, HasPtr) #mkField FormatFlags, FormatFlag +#mkField VideoCodecID, AVCodecID #hasField AVOutputFormat, FormatFlags, flags +#hasField AVOutputFormat, VideoCodecID, video_codec newtype AVIOContext = AVIOContext (Ptr ()) deriving (Storable, HasPtr) newtype AVPacket = AVPacket (Ptr ()) deriving (Storable, HasPtr) #mkField Data, (Ptr ()) -#hasField AVPacket, Data, data #mkField Size, CInt -#hasField AVPacket, Size, size +#mkField PacketFlags, PacketFlag +#mkField Dts, CLong +#hasField AVPacket, Data, data +#hasField AVPacket, Size, size +#hasField AVPacket, PacketFlags, flags #hasField AVPacket, StreamIndex, stream_index +#hasField AVPacket, Pts, pts +#hasField AVPacket, Dts, dts -- | @sizeof@ the 'AVPacket' structure in bytes. packetSize :: Int packetSize = #size AVPacket + +pictureSize :: Int +pictureSize = #size AVPicture -- * Types with Haskell equivalents diff --git a/src/nameCompat.h b/src/nameCompat.h --- a/src/nameCompat.h +++ b/src/nameCompat.h @@ -3,12 +3,17 @@ are locked down with these old versions, we hack in support for the newer constant names. */ +#define AV_PIX_FMT_NONE PIX_FMT_NONE #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_RGB8 -1 +#define AV_PIX_FMT_BGR8 -1 +#define AV_PIX_FMT_RGB4_BYTE -1 +#define AV_PIX_FMT_BGR4_BYTE -1 #define AV_PIX_FMT_GRAY8 PIX_FMT_GRAY8 #define AV_PIX_FMT_GRAY16 PIX_FMT_GRAY16 #define AV_PIX_FMT_GRAY8A -1 @@ -38,6 +43,9 @@ #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 AV_CODEC_ID_HEVC -1 +#define AV_CODEC_ID_VC1 -1 +#define AV_CODEC_ID_RAWVIDEO CODEC_ID_RAWVIDEO #define FF_PROFILE_AAC_HE -1 #define FF_PROFILE_AAC_HE_V2 -1