diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,21 @@ +0.4 +--- + +* Fixed corrupted output of palettized animated GIFs. + +* Added palettization options + + * Using `avPixFmtRgb8` results in a small file + + * Using the default pixel format (`avPixFmtPal8`) results in a good-looking, + fairly large file thanks to JuicyPixels's `palettize` function. + + * Setting the `epPreset` field of the `EncodingParams` value passed to + `frameWriter` to `"dither"` results in an even prettier, even larger GIF + file (again, thanks to JuicyPixels's `palettize` function). + + * See the `demo/Raster.hs` for examples. + 0.3.1 --- diff --git a/demo/Raster.hs b/demo/Raster.hs --- a/demo/Raster.hs +++ b/demo/Raster.hs @@ -87,9 +87,14 @@ -- | Animate the logo and write it to a video file! main :: IO () main = do initFFmpeg - -- We can change the output file extension to ".gif" to get - -- an animated gif! - w <- frameWriter (defaultParams 350 350) "logo.mov" + -- Change the output file extension to ".gif" to get an + -- animated gif! We can get a small GIF file by setting + -- 'epPixelFormat' to 'avPixFmtRgb8', but it might not look + -- very good. + w <- frameWriter params "logo.mov" forM_ path $ w . Just . V.unsafeCast . imageData . logoTest (uniformTexture blue) w Nothing + where params = defaultParams 350 350 + -- tinyGif = params { epPixelFormat = Just avPixFmtRgb8 } + -- prettyGif = params { preset = "dither" } 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.3.1 +version: 0.4 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to @@ -51,7 +51,7 @@ Codec.FFmpeg.Scaler, Codec.FFmpeg.Types, Codec.FFmpeg.Internal.Debug, - Codec.FFmpeg.Internal.V3 + Codec.FFmpeg.Internal.Linear build-tools: hsc2hs build-depends: base >=4.6 && < 5, vector >= 0.10.9 && < 0.11, 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 @@ -29,6 +29,9 @@ foreign import ccall "av_free_packet" free_packet :: AVPacket -> IO () +foreign import ccall "av_malloc" + av_malloc :: CSize -> IO (Ptr ()) + foreign import ccall "av_free" av_free :: Ptr () -> IO () 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 @@ -8,7 +8,7 @@ module Codec.FFmpeg.Encode where import Codec.FFmpeg.Common import Codec.FFmpeg.Enums -import Codec.FFmpeg.Internal.V3 +import Codec.FFmpeg.Internal.Linear import Codec.FFmpeg.Scaler import Codec.FFmpeg.Types import Codec.Picture @@ -20,8 +20,10 @@ import Data.Ord (comparing) import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as VM import Foreign.C.String import Foreign.C.Types +import Foreign.ForeignPtr (touchForeignPtr) import Foreign.Marshal.Alloc import Foreign.Marshal.Utils @@ -88,28 +90,43 @@ av_image_fill_arrays :: Ptr (Ptr CUChar) -> Ptr CInt -> Ptr CUChar -> AVPixelFormat -> CInt -> CInt -> CInt -> IO CInt +foreign import ccall "av_image_fill_linesizes" + av_image_fill_linesizes :: Ptr CInt -> AVPixelFormat -> CInt -> IO CInt + -- * FFmpeg Encoding Interface -- | Minimal parameters describing the desired video output. -data EncodingParams = EncodingParams { epWidth :: CInt - , epHeight :: CInt - , epFps :: Int - , 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 } +data EncodingParams = + EncodingParams { epWidth :: CInt + , epHeight :: CInt + , epFps :: Int + , epCodec :: Maybe AVCodecID + -- ^ If 'Nothing', then the codec is inferred from + -- the output file name. If 'Just', then this codec + -- is manually chosen. + , epPixelFormat :: Maybe AVPixelFormat + -- ^ If 'Nothing', automatically chose a pixel format + -- based on the output coded. If 'Just', force the + -- selected pixel format. + , epPreset :: String + -- ^ Encoder-specific hints. For h264, the default + -- preset is @\"medium\"@ (other options are + -- @\"fast\"@, @\"slow\"@, etc.). For the GIF codec, + -- setting this to @\"dither\"@ will enable dithering + -- during the palettization process. This will + -- improve image quality, but result in a larger + -- file. + } -- | Use default parameters for a video of the given width and -- height, forcing the choice of the h264 encoder. defaultH264 :: CInt -> CInt -> EncodingParams -defaultH264 w h = EncodingParams w h 30 (Just avCodecIdH264) "medium" +defaultH264 w h = EncodingParams w h 30 (Just avCodecIdH264) Nothing "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 Nothing "" +defaultParams w h = EncodingParams w h 30 Nothing Nothing "" -- | Determine if the bitwise intersection of two values is non-zero. checkFlag :: Bits a => a -> a -> Bool @@ -138,9 +155,11 @@ setHeight ctx (epHeight ep) let framePeriod = AVRational 1 (fromIntegral $ epFps ep) setTimeBase ctx framePeriod - setPixelFormat ctx $ case () of - _ | codec == avCodecIdRawvideo -> avPixFmtRgb24 - | codec == avCodecIdGif -> avPixFmtRgb8 + setPixelFormat ctx $ case epPixelFormat ep of + Just fmt -> fmt + Nothing + | codec == avCodecIdRawvideo -> avPixFmtRgb24 + | codec == avCodecIdGif -> avPixFmtPal8 | otherwise -> avPixFmtYuv420p -- Some formats want stream headers to be separate @@ -168,14 +187,19 @@ -- a destination before encoding the video frame. initTempFrame :: EncodingParams -> AVPixelFormat -> IO AVFrame initTempFrame ep fmt = do - yuv <- frame_alloc_check - setPixelFormat yuv fmt - setWidth yuv (epWidth ep) - setHeight yuv (epHeight ep) - setPts yuv 0 - frame_get_buffer_check yuv 32 - return yuv + frame <- frame_alloc_check + setPixelFormat frame fmt + setWidth frame (epWidth ep) + setHeight frame (epHeight ep) + setPts frame 0 + -- For palettized images, we will provide our own buffer. + if fmt == avPixFmtRgb8 || fmt == avPixFmtPal8 + then do r <- av_image_fill_linesizes (hasLineSize frame) fmt (epWidth ep) + when (r < 0) (errMsg "Error filling temporary frame line sizes") + else frame_get_buffer_check frame 32 + return frame + -- | Allocate an output context inferring the codec from the given -- file name. allocOutputContext :: FilePath -> IO AVFormatContext @@ -232,19 +256,40 @@ write_trailer_check oc = do r <- av_write_trailer oc when (r /= 0) (errMsg "Error writing trailer") --- | Quantize RGB24 pixels to the systematic RGB8 color palette. This --- is slow, but lets us prepare an RGB24 pixel format for output as an --- RGB8 GIF. -palettizeRGB8 :: V.Vector (V3 CUChar) -> V.Vector CUChar -palettizeRGB8 = V.map (searchPal . fmap fromIntegral) - where pal :: V.Vector (V3 CInt) - pal = V.generate 256 $ \i' -> +-- | Quantize RGB24 pixels to the systematic RGB8 color palette. The +-- image data has space for a palette appended to be compliant with +-- 'av_image_fill_arrays''s expectations. This is slow. +palettizeRGB8 :: EncodingParams -> V.Vector CUChar -> V.Vector CUChar +palettizeRGB8 ep = \pix -> V.create $ + do let pix' = V.unsafeCast pix :: V.Vector (V3 CUChar) + m <- VM.new (numPix + 1024) + V.mapM_ (\i -> let p = searchPal $ fromIntegral <$> (pix' V.! i) + in VM.unsafeWrite m i p) + (V.enumFromN 0 numPix) + VM.set (VM.unsafeSlice numPix 1024 m) 0 + return m + where numPix = fromIntegral $ epWidth ep * epHeight ep + pal :: V.Vector (V3 CInt) + pal = V.generate 256 $ \i' -> let i = fromIntegral i' in V3 ((i `shiftR` 5) * 36) (((i `shiftR` 2) .&. 7) * 36) ((i .&. 3) * 85) searchPal = fromIntegral . flip V.minIndexBy pal . comparing . qd +-- | High quality dithered, median cut palette using 'palettize'. The +-- result is packed such that the BGRA palette is laid out +-- contiguously following the palettized image data. +palettizeJuicy :: EncodingParams -> V.Vector CUChar -> V.Vector CUChar +palettizeJuicy ep pix = + let (pix', pal) = palettize (PaletteOptions MedianMeanCut doDither 256) + (mkImage $ V.unsafeCast pix) + pal' = V.map (\(V3 r g b) -> V4 b g r (255::CUChar)) + (V.unsafeCast $ imageData pal) + in V.unsafeCast (imageData pix') V.++ V.unsafeCast pal' + where mkImage = Image (fromIntegral $ epWidth ep) (fromIntegral $ epHeight ep) + doDither = epPreset ep == "dither" + -- | Open a target file for writing a video stream. The function -- returned may be used to write RGB images of the resolution given by -- the provided 'EncodingParams'. The function will convert the @@ -269,7 +314,7 @@ swsBilinear else return Nothing - pkt <- AVPacket <$> mallocBytes packetSize + pkt <- AVPacket <$> av_malloc (fromIntegral packetSize) stIndex <- getStreamIndex st avio_open_check oc fname @@ -279,7 +324,10 @@ codecTB <- getCodecContext st >>= getTimeBase isRaw <- checkFlag avfmtRawpicture <$> (getOutputFormat oc >>= getFormatFlags) - let frameTime = av_rescale_q 1 codecTB tb + let palettizer | dstFmt == avPixFmtPal8 = Just $ palettizeJuicy ep + | dstFmt == avPixFmtRgb8 = Just $ palettizeRGB8 ep + | otherwise = Nothing + frameTime = av_rescale_q 1 codecTB tb mkImage :: Vector CUChar -> Image PixelRGB8 mkImage = let [w,h] = map fromIntegral [epWidth ep, epHeight ep] in Image w h . V.unsafeCast @@ -288,9 +336,7 @@ setSize pkt 0 writePacket = do setStreamIndex pkt stIndex write_frame_check oc pkt - copyDstData - | dstFmt == avPixFmtRgb8 = copyDstDataAux . palettizeRGB8 . V.unsafeCast - | otherwise = copyDstDataAux + copyDstData = copyDstDataAux copyDstDataAux pixels = void . V.unsafeWith pixels $ \ptr -> @@ -320,14 +366,19 @@ flip when (writePacket >> addEncoded Nothing) addEncoded (Just pixels) = do resetPacket - fillDst pixels + let pixels' = maybe pixels ($ V.unsafeCast pixels) palettizer + fillDst pixels' getPts dstFrame >>= setPts dstFrame . (+ frameTime) encode_video_check ctx pkt (Just dstFrame) >>= flip when writePacket + -- Make sure the GC hasn't clobbered our palettized pixel data + let (fp,_,_) = V.unsafeToForeignPtr pixels' + touchForeignPtr fp addFrame = if isRaw then addRaw else addEncoded go Nothing = do addFrame Nothing write_trailer_check oc _ <- codec_close ctx with dstFrame av_frame_free + av_free (getPtr pkt) avio_close_check oc avformat_free_context oc go (Just pixels) = addFrame (Just pixels) 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 @@ -32,6 +32,7 @@ #enum AVPixelFormat,AVPixelFormat \ , AV_PIX_FMT_NONE\ , AV_PIX_FMT_RGB24\ + , AV_PIX_FMT_RGBA\ , AV_PIX_FMT_Y400A\ , AV_PIX_FMT_RGB32\ , AV_PIX_FMT_RGB32_1\ diff --git a/src/Codec/FFmpeg/Internal/Linear.hs b/src/Codec/FFmpeg/Internal/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Codec/FFmpeg/Internal/Linear.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | Minimal operations on small vector types. +module Codec.FFmpeg.Internal.Linear where +import Control.Applicative +import Foreign.C.Types +import Foreign.Ptr (castPtr) +import Foreign.Storable + +-- | A basic three component vector. +data V3 a = V3 !a !a !a + +instance Functor V3 where + fmap f (V3 x y z) = V3 (f x) (f y) (f z) + +instance Storable a => Storable (V3 a) where + sizeOf _ = 3 * sizeOf (undefined::a) + alignment _ = alignment (undefined::a) + peek ptr = let ptr' = castPtr ptr + in V3 <$> peek ptr' <*> peekElemOff ptr' 1 <*> peekElemOff ptr' 2 + poke ptr (V3 x y z) = let ptr' = castPtr ptr + in do poke ptr' x + pokeElemOff ptr' 1 y + pokeElemOff ptr' 2 z + +-- | Quadrance between two 3D points. +qd :: V3 CInt -> V3 CInt -> CInt +qd (V3 x1 y1 z1) (V3 x2 y2 z2) = let dx = x2 - x1 + dy = y2 - y1 + dz = z2 - z1 + in dx * dx + dy * dy + dz * dz + +data V4 a = V4 !a !a !a !a + +instance Functor V4 where + fmap f (V4 x y z w) = V4 (f x) (f y) (f z) (f w) + +instance Storable a => Storable (V4 a) where + sizeOf _ = 4 * sizeOf (undefined::a) + alignment _ = alignment (undefined::a) + peek ptr = let ptr' = castPtr ptr + in V4 <$> peek ptr' <*> peekElemOff ptr' 1 + <*> peekElemOff ptr' 2 <*> peekElemOff ptr' 3 + poke ptr (V4 x y z w) = let ptr' = castPtr ptr + in do poke ptr' x + pokeElemOff ptr' 1 y + pokeElemOff ptr' 2 z + pokeElemOff ptr' 3 w diff --git a/src/Codec/FFmpeg/Internal/V3.hs b/src/Codec/FFmpeg/Internal/V3.hs deleted file mode 100644 --- a/src/Codec/FFmpeg/Internal/V3.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} --- | A basic three component vector. -module Codec.FFmpeg.Internal.V3 where -import Control.Applicative -import Foreign.C.Types -import Foreign.Ptr (castPtr) -import Foreign.Storable - --- | A basic three component vector. -data V3 a = V3 !a !a !a - -instance Functor V3 where - fmap f (V3 x y z) = V3 (f x) (f y) (f z) - -instance Storable a => Storable (V3 a) where - sizeOf _ = 3 * sizeOf (undefined::a) - alignment _ = alignment (undefined::a) - peek ptr = let ptr' = castPtr ptr - in V3 <$> peek ptr' <*> peekElemOff ptr' 1 <*> peekElemOff ptr' 2 - poke ptr (V3 x y z) = let ptr' = castPtr ptr - in do poke ptr' x - pokeElemOff ptr' 1 y - pokeElemOff ptr' 2 z - --- | Quadrance between two 3D points. -qd :: V3 CInt -> V3 CInt -> CInt -qd (V3 x1 y1 z1) (V3 x2 y2 z2) = let dx = x2 - x1 - dy = y2 - y1 - dz = z2 - z1 - in dx * dx + dy * dy + dz * dz 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,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances #-} -- | Convert between FFmpeg frames and JuicyPixels images. module Codec.FFmpeg.Juicy where import Codec.Picture @@ -54,3 +54,16 @@ -- 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 JuicyPixelFormat a where + juicyPixelFormat :: proxy a -> AVPixelFormat + +instance JuicyPixelFormat Pixel8 where + juicyPixelFormat _ = avPixFmtGray8 + +instance JuicyPixelFormat PixelRGB8 where + juicyPixelFormat _ = avPixFmtRgb24 + +instance JuicyPixelFormat PixelRGBA8 where + juicyPixelFormat _ = avPixFmtRgba diff --git a/src/nameCompat.h b/src/nameCompat.h --- a/src/nameCompat.h +++ b/src/nameCompat.h @@ -5,6 +5,7 @@ #define AV_PIX_FMT_NONE PIX_FMT_NONE #define AV_PIX_FMT_RGB24 PIX_FMT_RGB24 +#define AV_PIX_FMT_RGBA PIX_FMT_RGBA #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