diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +0.5 +--- + +* Juiced the Encode and Decode APIs. + + Using `imageWriter` and `imageReader` provides a degree of pixel + format polymorphism based on JuicyPixels pixel types. + 0.4 --- diff --git a/demo/Main.hs b/demo/Main.hs --- a/demo/Main.hs +++ b/demo/Main.hs @@ -2,50 +2,52 @@ 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 +firstFrame = do (getFrame, cleanup) <- imageReader "myVideo.mov" + (fmap ImageRGB8 <$> getFrame) <* 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 () + do boom <- imageWriter (defaultParams sz sz) "pulse.mov" + let boom' = (boom :: Maybe (Image Pixel8) -> IO ()) . Just . Image sz sz + go :: Int -> Int -> Int -> IO () go 600 _ _ = boom Nothing - go n d i = do boom (Just $ V.replicate (fromIntegral $ sz*sz*3) - (fromIntegral i)) + go n d i = do boom' $ V.replicate (sz*sz) (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 + where sz :: Integral a => a + sz = 64 +-- | Generate a video that fades from white to gray to white. testEncode :: IO () testEncode = initFFmpeg >> pulseVid >> putStrLn "All done!" +-- | Decoding example. Try changing 'ImageRGB8' to 'ImageY8' in the +-- 'savePngImage' lines to automatically decode to grayscale images! testDecode :: FilePath -> IO () testDecode vidFile = do initFFmpeg - (getFrame, cleanup) <- frameReaderTime vidFile + (getFrame, cleanup) <- imageReaderTime vidFile frame1 <- getFrame case frame1 of Just (avf,ts) -> do putStrLn $ "Frame at "++show ts - saveJuicy "frame1.png" avf + savePngImage "frame1.png" (ImageRGB8 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 + savePngImage "frame2.png" (ImageRGB8 avf) Nothing -> putStrLn "No frame for me :(" cleanup putStrLn "All done!" diff --git a/demo/Raster.hs b/demo/Raster.hs --- a/demo/Raster.hs +++ b/demo/Raster.hs @@ -2,7 +2,6 @@ import Codec.FFmpeg import Codec.Picture import Control.Monad (forM_) -import qualified Data.Vector.Storable as V import Graphics.Rasterific import Graphics.Rasterific.Texture import Graphics.Rasterific.Transformations @@ -59,11 +58,22 @@ background = PixelRGB8 128 128 128 blue = PixelRGB8 0 020 150 +-- `fgSize` will determine our image size. `bgSize` is smaller so we +-- see the effect of the `SamplerRepeat` sampler. + +fgSize, fgScale, bgSize :: Float +fgSize = 350 +fgScale = fgSize / 100 +bgSize = 57 * fgScale + +fgSizei :: Integral a => a +fgSizei = floor fgSize + -- | A ring with a drop-shadow on the inside. The texture is repeated, -- resulting in concentric rings centered at @(200,200)@. bgGrad :: Texture PixelRGB8 bgGrad = withSampler SamplerRepeat $ - radialGradientTexture gradDef (V2 200 200) 100 + radialGradientTexture gradDef (V2 bgSize bgSize) (bgSize * 0.5) where gradDef = [(0 , PixelRGB8 255 255 255) ,(0.5, PixelRGB8 255 255 255) ,(0.5, PixelRGB8 255 255 255) @@ -75,13 +85,14 @@ -- | Adapted from the Rasterific logo example. logoTest :: Texture PixelRGB8 -> Vector -> Image PixelRGB8 -logoTest texture insetOrigin = renderDrawing 350 350 background (bg >> drawing) +logoTest texture insetOrigin = + renderDrawing fgSizei fgSizei background (bg >> drawing) where beziers = logo 40 False $ V2 10 10 inverse = logo 20 True $ (V2 20 20 + insetOrigin) - bg = withTexture bgGrad . fill $ rectangle (V2 0 0) 350 350 + bg = withTexture bgGrad . fill $ rectangle (V2 0 0) fgSize fgSize drawing = withTexture texture . fill - . transform (applyTransformation $ scale 3.5 3.5) + . transform (applyTransformation $ scale fgScale fgScale) $ beziers ++ inverse -- | Animate the logo and write it to a video file! @@ -91,10 +102,9 @@ -- 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 <- imageWriter params "logo.mov" + forM_ path $ w . Just . logoTest (uniformTexture blue) w Nothing - where params = defaultParams 350 350 + where params = defaultParams fgSizei fgSizei -- 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.4 +version: 0.5 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to @@ -10,11 +10,10 @@ > import Codec.FFmpeg > import Codec.Picture > import Control.Applicative - > import Control.Monad.Trans.Maybe > > go :: IO (Maybe DynamicImage) - > go = do (getFrame, cleanup) <- frameReaderT "myVideo.mov" - > (runMaybeT $ getFrame >>= toJuicyT) <* cleanup + > go = do (getFrame, cleanup) <- imageReader "myVideo.mov" + > (fmap ImageRGB8 <$> getFrame) <* cleanup . Tested on OS X 10.9.2 with 2.2.1 installed via . diff --git a/src/Codec/FFmpeg.hs b/src/Codec/FFmpeg.hs --- a/src/Codec/FFmpeg.hs +++ b/src/Codec/FFmpeg.hs @@ -6,8 +6,10 @@ -- * Decoding frameReader, frameReaderT, frameReaderTime, frameReaderTimeT, + imageReader, imageReaderTime, -- * Encoding - EncodingParams(..), defaultParams, frameWriter, + EncodingParams(..), defaultParams, + frameWriterRgb, imageWriter, -- * JuicyPixels interop toJuicy, toJuicyT, saveJuicy, -- * Types and Enums 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 @@ -76,3 +76,13 @@ frame_get_buffer_check f x = do r <- av_frame_get_buffer f x when (r /= 0) (errMsg "Failed to allocate buffers") + +-- | Bytes-per-pixel for an 'AVPixelFormat' +avPixelStride :: AVPixelFormat -> Maybe Int +avPixelStride fmt + | fmt == avPixFmtGray8 = Just 1 + | fmt == avPixFmtRgb24 = Just 3 + | fmt == avPixFmtRgba = Just 4 + | fmt == avPixFmtRgb8 = Just 1 + | fmt == avPixFmtPal8 = Just 1 + | otherwise = Nothing 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 @@ -131,31 +131,32 @@ -- | Read RGB frames from a video stream. frameReader :: (MonadIO m, Error e, MonadError e m) - => FilePath -> m (IO (Maybe AVFrame), IO ()) -frameReader fileName = + => AVPixelFormat -> FilePath -> m (IO (Maybe AVFrame), IO ()) +frameReader dstFmt fileName = do inputContext <- openInput fileName checkStreams inputContext (vidStreamIndex, ctx, cod) <- findVideoStream inputContext _ <- openCodec ctx cod - prepareReader inputContext vidStreamIndex ctx + prepareReader inputContext vidStreamIndex dstFmt 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 +frameReaderT = fmap (first MaybeT) . frameReader avPixFmtRgb24 -- | 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) - => FilePath -> m (IO (Maybe (AVFrame, Double)), IO ()) -frameReaderTime fileName = + => AVPixelFormat -> FilePath + -> m (IO (Maybe (AVFrame, Double)), IO ()) +frameReaderTime dstFmt fileName = do inputContext <- openInput fileName checkStreams inputContext (vidStreamIndex, ctx, cod) <- findVideoStream inputContext _ <- openCodec ctx cod - (reader, cleanup) <- prepareReader inputContext vidStreamIndex ctx + (reader, cleanup) <- prepareReader inputContext vidStreamIndex dstFmt ctx AVRational num den <- liftIO $ getTimeBase ctx let (numl, dend) = (fromIntegral num, fromIntegral den) frameTime' frame = @@ -174,14 +175,14 @@ -- > 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 +frameReaderTimeT = fmap (first MaybeT) . frameReaderTime avPixFmtRgb24 -- | 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) - => AVFormatContext -> CInt -> AVCodecContext + => AVFormatContext -> CInt -> AVPixelFormat -> AVCodecContext -> m (IO (Maybe AVFrame), IO ()) -prepareReader fmtCtx vidStream codCtx = +prepareReader fmtCtx vidStream dstFmt codCtx = wrapIOError $ do fRaw <- frame_alloc_check fRgb <- frame_alloc_check @@ -192,12 +193,11 @@ setWidth fRgb w setHeight fRgb h - setPixelFormat fRgb avPixFmtRgb24 + setPixelFormat fRgb dstFmt frame_get_buffer_check fRgb 32 - sws <- swsInit (ImageInfo w h fmt) (ImageInfo w h avPixFmtRgb24) - swsBilinear + sws <- swsInit (ImageInfo w h fmt) (ImageInfo w h dstFmt) swsBilinear pkt <- AVPacket <$> mallocBytes packetSize let cleanup = do with fRgb av_frame_free 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 @@ -18,6 +18,7 @@ import Data.Bits import Data.Maybe (fromMaybe) import Data.Ord (comparing) +import Data.Traversable (for) import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM @@ -106,7 +107,7 @@ -- is manually chosen. , epPixelFormat :: Maybe AVPixelFormat -- ^ If 'Nothing', automatically chose a pixel format - -- based on the output coded. If 'Just', force the + -- based on the output codec. If 'Just', force the -- selected pixel format. , epPreset :: String -- ^ Encoder-specific hints. For h264, the default @@ -291,27 +292,32 @@ 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 --- supplied RGB frame to YUV (specifically, @yuv420p@) before encoding --- the image to the video stream. If this function is applied to +-- returned may be used to write image frames (specified by a pixel +-- format, resolution, and pixel data). If this function is applied to -- 'Nothing', then the output stream is closed. Note that 'Nothing' -- /must/ be provided to properly terminate video encoding. -frameWriter :: EncodingParams -> FilePath -> IO (Maybe (Vector CUChar) -> IO ()) +-- +-- Support for source images that are of a different size to the +-- output resolution is limited to non-palettized destination formats +-- (i.e. those that are handled by @libswscaler@). Practically, this +-- means that animated gif output only works if the source images are +-- of the target resolution. +frameWriter :: EncodingParams -> FilePath + -> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()) frameWriter ep fname = do oc <- allocOutputContext fname (st,ctx) <- initStream ep oc dstFmt <- getPixelFormat ctx dstFrame <- initTempFrame ep dstFmt + let dstInfo = ImageInfo (epWidth ep) (epHeight ep) dstFmt -- 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 && dstFmt /= avPixFmtRgb8 then Just <$> swsInit (ImageInfo (epWidth ep) (epHeight ep) avPixFmtRgb24) - (ImageInfo (epWidth ep) (epHeight ep) dstFmt) - swsBilinear + dstInfo swsBilinear else return Nothing pkt <- AVPacket <$> av_malloc (fromIntegral packetSize) @@ -324,21 +330,24 @@ codecTB <- getCodecContext st >>= getTimeBase isRaw <- checkFlag avfmtRawpicture <$> (getOutputFormat oc >>= getFormatFlags) - let palettizer | dstFmt == avPixFmtPal8 = Just $ palettizeJuicy ep + let checkPalCompat + | dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8 = const True + | otherwise = \(srcFmt, V2 srcW srcH, _) -> + srcFmt == avPixFmtRgb24 && + srcW == epWidth ep && + srcH == epHeight ep + + 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 resetPacket = do init_packet pkt setData pkt nullPtr setSize pkt 0 writePacket = do setStreamIndex pkt stIndex write_frame_check oc pkt - copyDstData = copyDstDataAux - copyDstDataAux pixels = + copyDstData (_,_,pixels) = void . V.unsafeWith pixels $ \ptr -> av_image_fill_arrays (castPtr $ hasData dstFrame) (hasLineSize dstFrame) @@ -347,10 +356,11 @@ (epWidth ep) (epHeight ep) 1 - scaleToDst sws' pixels = void $ swsScale sws' (mkImage pixels) dstFrame - fillDst = maybe copyDstData scaleToDst sws + + scaleToDst sws' img = void $ swsScale sws' img dstFrame + fillDst = maybe copyDstData scaleToDst addRaw Nothing = return () - addRaw (Just pixels) = + addRaw (Just (_, _, pixels)) = do resetPacket getPacketFlags pkt >>= setPacketFlags pkt . (.|. avPktFlagKey) --setSize pkt (fromIntegral $ V.length pixels) @@ -364,10 +374,15 @@ addEncoded Nothing = do resetPacket encode_video_check ctx pkt Nothing >>= flip when (writePacket >> addEncoded Nothing) - addEncoded (Just pixels) = + addEncoded (Just srcImg@(srcFmt, V2 srcW srcH, pixels)) = do resetPacket + when (not $ checkPalCompat srcImg) + (error $ "Palettized output requires source images to be the \ + \same resolution as the output video") let pixels' = maybe pixels ($ V.unsafeCast pixels) palettizer - fillDst pixels' + sws' <- for sws $ \s -> + swsReset s (ImageInfo srcW srcH srcFmt) dstInfo swsBilinear + fillDst sws' (srcFmt, V2 srcW srcH, 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 @@ -381,5 +396,16 @@ av_free (getPtr pkt) avio_close_check oc avformat_free_context oc - go (Just pixels) = addFrame (Just pixels) + go img@(Just _) = addFrame img return go + +-- | 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' (i.e. the same resolution as the +-- output video). If this function is applied to 'Nothing', then the +-- output stream is closed. Note that 'Nothing' /must/ be provided to +-- properly terminate video encoding. +frameWriterRgb :: EncodingParams -> FilePath + -> IO (Maybe (Vector CUChar) -> IO ()) +frameWriterRgb ep f = (. fmap aux) <$> frameWriter ep f + where aux pixels = (avPixFmtRgb24, V2 (epWidth ep) (epHeight ep), pixels) diff --git a/src/Codec/FFmpeg/Internal/Linear.hs b/src/Codec/FFmpeg/Internal/Linear.hs --- a/src/Codec/FFmpeg/Internal/Linear.hs +++ b/src/Codec/FFmpeg/Internal/Linear.hs @@ -6,7 +6,10 @@ import Foreign.Ptr (castPtr) import Foreign.Storable --- | A basic three component vector. +-- | A two-component vector +data V2 a = V2 !a !a + +-- | A three-component vector data V3 a = V3 !a !a !a instance Functor V3 where @@ -29,6 +32,7 @@ dz = z2 - z1 in dx * dx + dy * dy + dz * dz +-- | A four-component vector data V4 a = V4 !a !a !a !a instance Functor V4 where 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,12 +1,19 @@ -{-# LANGUAGE FlexibleContexts, TypeSynonymInstances #-} +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, TypeSynonymInstances #-} -- | Convert between FFmpeg frames and JuicyPixels images. module Codec.FFmpeg.Juicy where import Codec.Picture +import Codec.FFmpeg.Common +import Codec.FFmpeg.Decode +import Codec.FFmpeg.Encode import Codec.FFmpeg.Enums +import Codec.FFmpeg.Internal.Linear (V2(..)) import Codec.FFmpeg.Types import Control.Applicative -import Control.Arrow ((&&&)) -import Control.Monad (when, (>=>)) +import Control.Arrow (first, (&&&)) +import Control.Monad ((>=>)) +import Control.Monad.Error.Class +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Data.Foldable (traverse_) import qualified Data.Vector.Storable as V @@ -14,6 +21,7 @@ import Foreign.C.Types import Foreign.Marshal.Array (advancePtr, copyArray) import Foreign.Ptr (castPtr, Ptr) +import Foreign.Storable (sizeOf) -- | Convert an 'AVFrame' to a 'DynamicImage' with the result in the -- 'MaybeT' transformer. @@ -24,39 +32,57 @@ -- | Convert an 'AVFrame' to a 'DynamicImage'. toJuicy :: AVFrame -> IO (Maybe DynamicImage) -toJuicy frame = do - fmt <- getPixelFormat frame - when (fmt /= avPixFmtRgb24) - (putStrLn "Not RGB24?!") - w <- fromIntegral <$> getWidth frame - h <- fromIntegral <$> getHeight frame - pixels <- castPtr <$> getData frame :: IO (Ptr CUChar) - srcStride <- fromIntegral <$> getLineSize frame - let dstStride = w * 3 - v <- VM.new (w*h*3) - VM.unsafeWith v $ \vptr -> - mapM_ (\(i,o) -> copyArray (advancePtr vptr o) - (advancePtr pixels i) - (w * 3)) - (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')) - return $ - case () of - _ | fmt == avPixFmtRgb24 -> mkImage ImageRGB8 - | fmt == avPixFmtGray8 -> mkImage ImageY8 - | fmt == avPixFmtGray16 -> mkImage ImageY16 - | otherwise -> Nothing +toJuicy frame = runMaybeT $ do + fmt <- lift $ getPixelFormat frame + pixelStride <- MaybeT . return $ avPixelStride fmt + 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')) + 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 + -- | 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 JuicyPixelFormat a where +class Pixel a => JuicyPixelFormat a where juicyPixelFormat :: proxy a -> AVPixelFormat instance JuicyPixelFormat Pixel8 where @@ -67,3 +93,47 @@ instance JuicyPixelFormat PixelRGBA8 where juicyPixelFormat _ = avPixFmtRgba + +-- | Bytes-per-pixel for a JuicyPixels 'Pixel' type. +juicyPixelStride :: forall a proxy. Pixel a => proxy a -> Int +juicyPixelStride _ = + sizeOf (undefined :: PixelBaseComponent a) * componentCount (undefined :: a) + +-- | Read RGB frames from a video stream. +imageReader :: forall m p e. + (Functor m, MonadIO m, Error e, MonadError e m, + JuicyPixelFormat p) + => FilePath -> m (IO (Maybe (Image p)), IO ()) +imageReader = fmap (first (runMaybeT . aux toJuicyImage)) + . frameReader (juicyPixelFormat ([] :: [p])) + where aux g x = MaybeT x >>= MaybeT . g + +-- | Read time stamped RGB frames from a video stream. Time is given +-- in seconds from the start of the stream. +imageReaderTime :: forall m p e. + (Functor m, MonadIO m, Error e, MonadError e m, + JuicyPixelFormat p) + => FilePath -> m (IO (Maybe (Image p, Double)), IO ()) +imageReaderTime = fmap (first (runMaybeT . aux toJuicyImage)) + . frameReaderTime (juicyPixelFormat ([] :: [p])) + where aux g x = do (f,t) <- MaybeT x + f' <- MaybeT $ g f + return (f', t) + +-- | Open a target file for writing a video stream. When the returned +-- function is applied to 'Nothing', the output stream is closed. Note +-- that 'Nothing' /must/ be provided when finishing in order to +-- properly terminate video encoding. +-- +-- Support for source images that are of a different size to the +-- output resolution is limited to non-palettized destination formats +-- (i.e. those that are handled by @libswscaler@). Practically, this +-- means that animated gif output is only supported if the source +-- images are of the target resolution. +imageWriter :: forall p. JuicyPixelFormat p + => EncodingParams -> FilePath -> IO (Maybe (Image p) -> IO ()) +imageWriter ep f = (. fmap aux) <$> frameWriter ep f + where aux img = let w = fromIntegral $ imageWidth img + h = fromIntegral $ imageHeight img + p = V.unsafeCast $ imageData img + in (juicyPixelFormat ([]::[p]), V2 w h, p) diff --git a/src/Codec/FFmpeg/Scaler.hs b/src/Codec/FFmpeg/Scaler.hs --- a/src/Codec/FFmpeg/Scaler.hs +++ b/src/Codec/FFmpeg/Scaler.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, ScopedTypeVariables, + UndecidableInstances #-} module Codec.FFmpeg.Scaler where import Codec.FFmpeg.Common import Codec.FFmpeg.Enums +import Codec.FFmpeg.Internal.Linear (V2(..)) import Codec.FFmpeg.Types import Codec.Picture +import Data.Maybe (fromMaybe) import qualified Data.Vector.Storable as V import Foreign.C.Types import Foreign.Marshal.Array (withArray) @@ -14,13 +17,17 @@ , imgHeight :: CInt , imgFormat :: AVPixelFormat } +-- | @swsInit srcInfo dstInfo alg@ initializations an 'SwsContext' to +-- scale and convert from @srcInfo@ to @dstInfo@ using the algorithm +-- @alg@ when scaling. 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. +-- and a new, configured context is returned. See 'swsInit' for a +-- description of the arguments. swsReset :: SwsContext -> ImageInfo -> ImageInfo -> SwsAlgorithm -> IO SwsContext swsReset ctx src dst alg = sws_getCachedContext ctx @@ -51,6 +58,15 @@ componentCount (undefined :: a) stride = fromIntegral $ imageWidth img * sz sliceHeight img k = k (fromIntegral $ imageHeight img) + +instance SwsCompatible (AVPixelFormat, V2 CInt, V.Vector CUChar) where + swsPlanes (_,_,p) k = V.unsafeWith p $ \ptr -> + withArray (castPtr ptr : replicate 7 nullPtr) k + swsStrides (fmt, V2 w _, _) k = withArray (stride : replicate 7 0) k + where sz = fromMaybe (error $ "Unknown pixel stride for format "++show fmt) + (avPixelStride fmt) + stride = w * fromIntegral sz + sliceHeight (_, V2 _ h, _) k = k h -- | Supplies a continuation with all components provided by the -- 'SwsCompatible' class.