diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +0.3.1 +--- + +* Automatically palettize RGB24 to RGB8 for GIF output. + +* Add a Rasterific demo program that records an animation. + 0.3 --- diff --git a/demo/Raster.hs b/demo/Raster.hs new file mode 100644 --- /dev/null +++ b/demo/Raster.hs @@ -0,0 +1,95 @@ +module Main where +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 +import Linear + +-- | The Rasterific logo sample shape. +logo :: Int -> Bool -> Vector -> [Primitive] +logo size inv offset = map BezierPrim . bezierFromPath . way $ map (^+^ offset) + [ (V2 0 is) + , (V2 0 0) + , (V2 is 0) + , (V2 is2 0) + , (V2 is2 is) + , (V2 is2 is2) + , (V2 is is2) + , (V2 0 is2) + , (V2 0 is) + ] + where is = fromIntegral size + is2 = is + is + + way | inv = reverse + | otherwise = id + +-- | Sample a quadratic bezier curve. +bezierInterp :: Bezier -> [Point] +bezierInterp (Bezier a b c) = go 0 + where v1 = b - a + v2 = c - b + go t + | t >= 1 = [] + | otherwise = let q0 = a + v1 ^* t + q1 = b + v2 ^* t + vq = q1 - q0 + in q0 + t *^ vq : (go $! t + 0.05) + +-- | Our animation path. +path :: [Point] +path = concatMap bezierInterp $ + bezierFromPath [ (V2 0 is) + , (V2 0 0) + , (V2 (is+5) 0) + , (V2 (is2+10) 0) + , (V2 (is2+10) is) + , (V2 (is2+10) is2) + , (V2 (is+5) is2) + , (V2 0 is2) + , (V2 0 is) + ] + where is = 15 + is2 = is + is + +background, blue :: PixelRGB8 +background = PixelRGB8 128 128 128 +blue = PixelRGB8 0 020 150 + +-- | 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 + where gradDef = [(0 , PixelRGB8 255 255 255) + ,(0.5, PixelRGB8 255 255 255) + ,(0.5, PixelRGB8 255 255 255) + ,(0.525, PixelRGB8 255 255 255) + ,(0.675, PixelRGB8 128 128 128) + ,(0.75, PixelRGB8 100 149 237) + ,(1, PixelRGB8 100 149 237) + ] + +-- | Adapted from the Rasterific logo example. +logoTest :: Texture PixelRGB8 -> Vector -> Image PixelRGB8 +logoTest texture insetOrigin = renderDrawing 350 350 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 + drawing = withTexture texture . fill + . transform (applyTransformation $ scale 3.5 3.5) + $ beziers ++ inverse + +-- | 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" + forM_ path $ + w . Just . V.unsafeCast . imageData . logoTest (uniformTexture blue) + w Nothing 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.0.1 +version: 0.3.1 synopsis: Minimal bindings to the FFmpeg library. description: Stream frames from an encoded video, or stream frames to @@ -37,6 +37,10 @@ description: Build demo executable default: False +flag BuildRasterDemo + description: Build Rasterific demo executable + default: False + library exposed-modules: Codec.FFmpeg, Codec.FFmpeg.Common, @@ -46,7 +50,8 @@ Codec.FFmpeg.Juicy, Codec.FFmpeg.Scaler, Codec.FFmpeg.Types, - Codec.FFmpeg.Internal.Debug + Codec.FFmpeg.Internal.Debug, + Codec.FFmpeg.Internal.V3 build-tools: hsc2hs build-depends: base >=4.6 && < 5, vector >= 0.10.9 && < 0.11, @@ -68,4 +73,16 @@ 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 + if flag(BuildRasterDemo) + build-depends: Rasterific, linear + hs-source-dirs: demo + main-is: Raster.hs + default-language: Haskell2010 + ghc-options: -Wall -O2 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 @@ -2,9 +2,13 @@ -- | Video encoding API. Includes FFI declarations for the underlying -- FFmpeg functions, wrappers for these functions that wrap error -- condition checking, and high level Haskellized interfaces. +-- +-- Note: If you need to import this module, consider qualifying the +-- import. module Codec.FFmpeg.Encode where import Codec.FFmpeg.Common import Codec.FFmpeg.Enums +import Codec.FFmpeg.Internal.V3 import Codec.FFmpeg.Scaler import Codec.FFmpeg.Types import Codec.Picture @@ -13,6 +17,7 @@ import Control.Monad.Error.Class import Data.Bits import Data.Maybe (fromMaybe) +import Data.Ord (comparing) import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable as V import Foreign.C.String @@ -49,7 +54,7 @@ av_freep :: Ptr (Ptr a) -> IO () foreign import ccall "av_guess_format" - guess_format :: CString -> CString -> CString -> IO AVOutputFormat + av_guess_format :: CString -> CString -> CString -> IO AVOutputFormat foreign import ccall "avformat_alloc_output_context2" avformat_alloc_output_context :: Ptr AVFormatContext -> AVOutputFormat @@ -135,7 +140,7 @@ setTimeBase ctx framePeriod setPixelFormat ctx $ case () of _ | codec == avCodecIdRawvideo -> avPixFmtRgb24 - | codec == avCodecIdGif -> avPixFmtPal8 + | codec == avCodecIdGif -> avPixFmtRgb8 | otherwise -> avPixFmtYuv420p -- Some formats want stream headers to be separate @@ -148,10 +153,10 @@ -- withCString (preset ep) $ \vStr -> -- av_opt_set ((#ptr AVCodecContext, priv_data) (getPtr ctx)) -- kStr vStr 0 - -- _ <- withCString "preset" $ \kStr -> - -- withCString "medium" $ \vStr -> - -- av_opt_set ((#ptr AVCodecContext, priv_data) (getPtr ctx)) - -- kStr vStr 0 + when (not . null $ epPreset ep) . void $ + withCString "preset" $ \kStr -> + withCString (epPreset ep) $ \vStr -> + getPrivData ctx >>= \pd -> av_opt_set pd kStr vStr 0 rOpen <- open_codec ctx cod nullPtr when (rOpen < 0) (throwError $ strMsg "Couldn't open codec") @@ -227,6 +232,19 @@ 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' -> + 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 + -- | 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 @@ -244,7 +262,7 @@ -- 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 + sws <- if dstFmt /= avPixFmtPal8 && dstFmt /= avPixFmtRgb8 then Just <$> swsInit (ImageInfo (epWidth ep) (epHeight ep) avPixFmtRgb24) (ImageInfo (epWidth ep) (epHeight ep) dstFmt) @@ -270,7 +288,11 @@ setSize pkt 0 writePacket = do setStreamIndex pkt stIndex write_frame_check oc pkt - copyDstData pixels = + copyDstData + | dstFmt == avPixFmtRgb8 = copyDstDataAux . palettizeRGB8 . V.unsafeCast + | otherwise = copyDstDataAux + + copyDstDataAux pixels = void . V.unsafeWith pixels $ \ptr -> av_image_fill_arrays (castPtr $ hasData dstFrame) (hasLineSize dstFrame) @@ -285,7 +307,8 @@ addRaw (Just pixels) = do resetPacket getPacketFlags pkt >>= setPacketFlags pkt . (.|. avPktFlagKey) - setSize pkt (fromIntegral $ V.length pixels) + --setSize pkt (fromIntegral $ V.length pixels) + setSize pkt (fromIntegral pictureSize) getPts dstFrame >>= setPts dstFrame . (+ frameTime) getPts dstFrame >>= setPts pkt getPts dstFrame >>= setDts pkt diff --git a/src/Codec/FFmpeg/Internal/V3.hs b/src/Codec/FFmpeg/Internal/V3.hs new file mode 100644 --- /dev/null +++ b/src/Codec/FFmpeg/Internal/V3.hs @@ -0,0 +1,30 @@ +{-# 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/Types.hsc b/src/Codec/FFmpeg/Types.hsc --- a/src/Codec/FFmpeg/Types.hsc +++ b/src/Codec/FFmpeg/Types.hsc @@ -42,6 +42,7 @@ #mkField PixelFormat, AVPixelFormat #mkField CodecFlags, CodecFlag #mkField CodecID, AVCodecID +#mkField PrivData, (Ptr ()) #hasField AVCodecContext, Width, width #hasField AVCodecContext, Height, height @@ -50,6 +51,7 @@ #hasField AVCodecContext, PixelFormat, pix_fmt #hasField AVCodecContext, CodecFlags, flags #hasField AVCodecContext, CodecID, codec_id +#hasField AVCodecContext, PrivData, priv_data newtype AVStream = AVStream (Ptr ()) deriving (Storable, HasPtr)