{-# LINE 1 "src/Codec/FFmpeg/Encode.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface #-}
-- | 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.Linear
import Codec.FFmpeg.Scaler
import Codec.FFmpeg.Types
import Codec.Picture
import Control.Monad (when, void)
import Data.Bits
import Data.IORef
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
import Foreign.C.String
import Foreign.C.Types
import Foreign.ForeignPtr (touchForeignPtr)
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils

import Foreign.Ptr
import Foreign.Storable



-- Based on the FFmpeg muxing example
-- http://www.ffmpeg.org/doxygen/2.1/doc_2examples_2muxing_8c-example.html

-- * FFI Declarations

foreign import ccall "avcodec_find_encoder"
  avcodec_find_encoder :: AVCodecID -> IO AVCodec

foreign import ccall "avcodec_find_encoder_by_name"
  avcodec_find_encoder_by_name :: CString -> IO AVCodec

foreign import ccall "av_opt_set"
  av_opt_set :: Ptr () -> CString -> CString -> CInt -> IO CInt

foreign import ccall "avcodec_encode_video2"
  avcodec_encode_video2 :: AVCodecContext -> AVPacket -> AVFrame -> Ptr CInt
                        -> IO CInt

foreign import ccall "av_image_alloc"
  av_image_alloc :: Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> CInt
                 -> AVPixelFormat -> CInt -> IO CInt

foreign import ccall "av_freep"
  av_freep :: Ptr (Ptr a) -> IO ()

foreign import ccall "av_guess_format"
  av_guess_format :: CString -> CString -> CString -> IO AVOutputFormat

foreign import ccall "avformat_alloc_output_context2"
  avformat_alloc_output_context2 :: Ptr AVFormatContext -> AVOutputFormat
                                 -> CString -> CString -> IO CInt

foreign import ccall "avformat_new_stream"
  avformat_new_stream :: AVFormatContext -> AVCodec -> IO AVStream

foreign import ccall "av_write_frame"
  av_write_frame :: AVFormatContext -> AVPacket -> IO CInt

foreign import ccall "av_interleaved_write_frame"
  av_interleaved_write_frame :: AVFormatContext -> AVPacket -> IO CInt

foreign import ccall "avformat_write_header"
  avformat_write_header :: AVFormatContext -> Ptr AVDictionary -> IO CInt

foreign import ccall "av_write_trailer"
  av_write_trailer :: AVFormatContext -> IO CInt

foreign import ccall "avio_open"
  avio_open :: Ptr AVIOContext -> CString -> AVIOFlag -> IO CInt

foreign import ccall "avio_close"
  avio_close :: AVIOContext -> IO CInt

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

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 { EncodingParams -> CInt
epWidth  :: CInt
                 , EncodingParams -> CInt
epHeight :: CInt
                 , EncodingParams -> Int
epFps    :: Int
                 , EncodingParams -> Maybe AVCodecID
epCodec  :: Maybe AVCodecID
                 -- ^ If 'Nothing', then the codec is inferred from
                 -- the output file name. If 'Just', then this codec
                 -- is manually chosen.
                 , EncodingParams -> Maybe AVPixelFormat
epPixelFormat :: Maybe AVPixelFormat
                 -- ^ If 'Nothing', automatically chose a pixel format
                 -- based on the output codec. If 'Just', force the
                 -- selected pixel format.
                 , EncodingParams -> String
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.
                 , EncodingParams -> Maybe String
epFormatName :: Maybe String
                 -- ^ FFmpeg muxer format name. If 'Nothing', tries to infer
                 -- from the output file name. If 'Just', the string value
                 -- should be the one available in @ffmpeg -formats@.
                 }

-- | Use default parameters for a video of the given width and
-- height, forcing the choice of the h264 encoder.
defaultH264 :: CInt -> CInt -> EncodingParams
defaultH264 :: CInt -> CInt -> EncodingParams
defaultH264 w :: CInt
w h :: CInt
h = CInt
-> CInt
-> Int
-> Maybe AVCodecID
-> Maybe AVPixelFormat
-> String
-> Maybe String
-> EncodingParams
EncodingParams CInt
w CInt
h 30 (AVCodecID -> Maybe AVCodecID
forall a. a -> Maybe a
Just AVCodecID
avCodecIdH264) Maybe AVPixelFormat
forall a. Maybe a
Nothing "medium" Maybe String
forall a. Maybe a
Nothing

-- | 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 :: CInt -> CInt -> EncodingParams
defaultParams w :: CInt
w h :: CInt
h = CInt
-> CInt
-> Int
-> Maybe AVCodecID
-> Maybe AVPixelFormat
-> String
-> Maybe String
-> EncodingParams
EncodingParams CInt
w CInt
h 30 Maybe AVCodecID
forall a. Maybe a
Nothing Maybe AVPixelFormat
forall a. Maybe a
Nothing "" Maybe String
forall a. Maybe a
Nothing

-- | Determine if the bitwise intersection of two values is non-zero.
checkFlag :: Bits a => a -> a -> Bool
checkFlag :: a -> a -> Bool
checkFlag flg :: a
flg = \x :: a
x -> (a
flg a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
x) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
allZeroBits
  where allZeroBits :: a
allZeroBits = a -> Int -> a
forall a. Bits a => a -> Int -> a
clearBit (Int -> a
forall a. Bits a => Int -> a
bit 0) 0

-- | Find and initialize the requested encoder, and add a video stream
-- to the output container.
initStream :: EncodingParams -> AVFormatContext -> IO (AVStream, AVCodecContext)
initStream :: EncodingParams -> AVFormatContext -> IO (AVStream, AVCodecContext)
initStream ep :: EncodingParams
ep _
  | (EncodingParams -> CInt
epWidth EncodingParams
ep CInt -> CInt -> CInt
forall a. Integral a => a -> a -> a
`rem` 2, EncodingParams -> CInt
epHeight EncodingParams
ep CInt -> CInt -> CInt
forall a. Integral a => a -> a -> a
`rem` 2) (CInt, CInt) -> (CInt, CInt) -> Bool
forall a. Eq a => a -> a -> Bool
/= (0,0) =
    String -> IO (AVStream, AVCodecContext)
forall a. HasCallStack => String -> a
error "Video dimensions must be multiples of two"
initStream ep :: EncodingParams
ep oc :: AVFormatContext
oc = do
  -- Use the codec suggested by the output format, or override with
  -- the user's choice.
  AVCodecID
codec <- IO AVCodecID
-> (AVCodecID -> IO AVCodecID) -> Maybe AVCodecID -> IO AVCodecID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AVFormatContext -> IO AVOutputFormat
forall t. HasOutputFormat t => t -> IO AVOutputFormat
getOutputFormat AVFormatContext
oc IO AVOutputFormat
-> (AVOutputFormat -> IO AVCodecID) -> IO AVCodecID
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AVOutputFormat -> IO AVCodecID
forall t. HasVideoCodecID t => t -> IO AVCodecID
getVideoCodecID) AVCodecID -> IO AVCodecID
forall (m :: * -> *) a. Monad m => a -> m a
return (EncodingParams -> Maybe AVCodecID
epCodec EncodingParams
ep)
  AVCodec
cod <- AVCodecID -> IO AVCodec
avcodec_find_encoder AVCodecID
codec
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AVCodec -> Ptr ()
forall a. HasPtr a => a -> Ptr ()
getPtr AVCodec
cod Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr)
       (String -> IO ()
forall a. HasCallStack => String -> a
error "Couldn't find encoder")

  AVStream
st <- AVFormatContext -> AVCodec -> IO AVStream
avformat_new_stream AVFormatContext
oc AVCodec
cod
  AVFormatContext -> IO CInt
forall t. HasNumStreams t => t -> IO CInt
getNumStreams AVFormatContext
oc IO CInt -> (CInt -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AVStream -> CInt -> IO ()
forall t. HasId t => t -> CInt -> IO ()
setId AVStream
st (CInt -> IO ()) -> (CInt -> CInt) -> CInt -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
subtract 1
  let framePeriod :: AVRational
framePeriod = CInt -> CInt -> AVRational
AVRational 1 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ EncodingParams -> Int
epFps EncodingParams
ep)
  AVStream -> AVRational -> IO ()
forall t. HasTimeBase t => t -> AVRational -> IO ()
setTimeBase AVStream
st AVRational
framePeriod
  AVCodecContext
ctx <- AVStream -> IO AVCodecContext
forall t. HasCodecContext t => t -> IO AVCodecContext
getCodecContext AVStream
st
  AVCodecContext -> CInt -> IO ()
forall t. HasWidth t => t -> CInt -> IO ()
setWidth AVCodecContext
ctx (EncodingParams -> CInt
epWidth EncodingParams
ep)
  AVCodecContext -> CInt -> IO ()
forall t. HasHeight t => t -> CInt -> IO ()
setHeight AVCodecContext
ctx (EncodingParams -> CInt
epHeight EncodingParams
ep)
  AVCodecContext -> AVRational -> IO ()
forall t. HasTimeBase t => t -> AVRational -> IO ()
setTimeBase AVCodecContext
ctx AVRational
framePeriod
  AVCodecContext -> AVPixelFormat -> IO ()
forall t. HasPixelFormat t => t -> AVPixelFormat -> IO ()
setPixelFormat AVCodecContext
ctx (AVPixelFormat -> IO ()) -> AVPixelFormat -> IO ()
forall a b. (a -> b) -> a -> b
$ case EncodingParams -> Maybe AVPixelFormat
epPixelFormat EncodingParams
ep of
                         Just fmt :: AVPixelFormat
fmt -> AVPixelFormat
fmt
                         Nothing
                           | AVCodecID
codec AVCodecID -> AVCodecID -> Bool
forall a. Eq a => a -> a -> Bool
== AVCodecID
avCodecIdRawvideo -> AVPixelFormat
avPixFmtRgb24
                           | AVCodecID
codec AVCodecID -> AVCodecID -> Bool
forall a. Eq a => a -> a -> Bool
== AVCodecID
avCodecIdGif -> AVPixelFormat
avPixFmtPal8
                           | Bool
otherwise -> AVPixelFormat
avPixFmtYuv420p

  -- Some formats want stream headers to be separate
  Bool
needsHeader <- FormatFlag -> FormatFlag -> Bool
forall a. Bits a => a -> a -> Bool
checkFlag FormatFlag
avfmtGlobalheader (FormatFlag -> Bool) -> IO FormatFlag -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                 (AVFormatContext -> IO AVOutputFormat
forall t. HasOutputFormat t => t -> IO AVOutputFormat
getOutputFormat AVFormatContext
oc IO AVOutputFormat
-> (AVOutputFormat -> IO FormatFlag) -> IO FormatFlag
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AVOutputFormat -> IO FormatFlag
forall t. HasFormatFlags t => t -> IO FormatFlag
getFormatFlags)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsHeader (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$

{-# LINE 178 "src/Codec/FFmpeg/Encode.hsc" #-}
    AVCodecContext -> IO CodecFlag
forall t. HasCodecFlags t => t -> IO CodecFlag
getCodecFlags AVCodecContext
ctx IO CodecFlag -> (CodecFlag -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AVCodecContext -> CodecFlag -> IO ()
forall t. HasCodecFlags t => t -> CodecFlag -> IO ()
setCodecFlags AVCodecContext
ctx (CodecFlag -> IO ())
-> (CodecFlag -> CodecFlag) -> CodecFlag -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CodecFlag -> CodecFlag -> CodecFlag
forall a. Bits a => a -> a -> a
.|. CodecFlag
avCodecFlagGlobalHeader)

{-# LINE 180 "src/Codec/FFmpeg/Encode.hsc" #-}

  -- _ <- withCString "vprofile" $ \kStr ->
  --        withCString (preset ep) $ \vStr ->
  --          av_opt_set ((#ptr AVCodecContext, priv_data) (getPtr ctx))
  --                     kStr vStr 0
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ EncodingParams -> String
epPreset EncodingParams
ep) (IO () -> IO ()) -> (IO CInt -> IO ()) -> IO CInt -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString "preset" ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \kStr :: CString
kStr ->
      String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString (EncodingParams -> String
epPreset EncodingParams
ep) ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \vStr :: CString
vStr ->
        AVCodecContext -> IO (Ptr ())
forall t. HasPrivData t => t -> IO (Ptr ())
getPrivData AVCodecContext
ctx IO (Ptr ()) -> (Ptr () -> IO CInt) -> IO CInt
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \pd :: Ptr ()
pd -> Ptr () -> CString -> CString -> CInt -> IO CInt
av_opt_set Ptr ()
pd CString
kStr CString
vStr 0

  CInt
rOpen <- AVCodecContext -> AVCodec -> Ptr AVDictionary -> IO CInt
open_codec AVCodecContext
ctx AVCodec
cod Ptr AVDictionary
forall a. Ptr a
nullPtr
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
rOpen CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall a. HasCallStack => String -> a
error "Couldn't open codec")

  (AVStream, AVCodecContext) -> IO (AVStream, AVCodecContext)
forall (m :: * -> *) a. Monad m => a -> m a
return (AVStream
st, AVCodecContext
ctx)

-- | 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.
initTempFrame :: EncodingParams -> AVPixelFormat -> IO AVFrame
initTempFrame :: EncodingParams -> AVPixelFormat -> IO AVFrame
initTempFrame ep :: EncodingParams
ep fmt :: AVPixelFormat
fmt = do
  AVFrame
frame <- IO AVFrame
frame_alloc_check
  AVFrame -> AVPixelFormat -> IO ()
forall t. HasPixelFormat t => t -> AVPixelFormat -> IO ()
setPixelFormat AVFrame
frame AVPixelFormat
fmt
  AVFrame -> CInt -> IO ()
forall t. HasWidth t => t -> CInt -> IO ()
setWidth AVFrame
frame (EncodingParams -> CInt
epWidth EncodingParams
ep)
  AVFrame -> CInt -> IO ()
forall t. HasHeight t => t -> CInt -> IO ()
setHeight AVFrame
frame (EncodingParams -> CInt
epHeight EncodingParams
ep)
  AVFrame -> CLong -> IO ()
forall t. HasPts t => t -> CLong -> IO ()
setPts AVFrame
frame 0

  -- For palettized images, we will provide our own buffer.
  if AVPixelFormat
fmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtRgb8 Bool -> Bool -> Bool
|| AVPixelFormat
fmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtPal8
  then do CInt
r <- Ptr CInt -> AVPixelFormat -> CInt -> IO CInt
av_image_fill_linesizes (AVFrame -> Ptr CInt
forall t. HasLineSize t => t -> Ptr CInt
hasLineSize AVFrame
frame) AVPixelFormat
fmt (EncodingParams -> CInt
epWidth EncodingParams
ep)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall a. HasCallStack => String -> a
error "Error filling temporary frame line sizes")
  else AVFrame -> CInt -> IO ()
frame_get_buffer_check AVFrame
frame 32
  AVFrame -> IO AVFrame
forall (m :: * -> *) a. Monad m => a -> m a
return AVFrame
frame

-- | Allocate an output context inferring the codec from the given
-- file name.
allocOutputContext :: Maybe String -> FilePath -> IO AVFormatContext
allocOutputContext :: Maybe String -> String -> IO AVFormatContext
allocOutputContext outputFormat :: Maybe String
outputFormat fname :: String
fname =
  let
    withFormat :: (CString -> IO a) -> IO a
withFormat = case Maybe String
outputFormat of
      Just f :: String
f -> String -> (CString -> IO a) -> IO a
forall a. String -> (CString -> IO a) -> IO a
withCString String
f
      Nothing -> (\f :: CString -> IO a
f -> CString -> IO a
f CString
forall a. Ptr a
nullPtr)
  in do
  AVFormatContext
oc <- (Ptr AVFormatContext -> IO AVFormatContext) -> IO AVFormatContext
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr AVFormatContext -> IO AVFormatContext) -> IO AVFormatContext)
-> (Ptr AVFormatContext -> IO AVFormatContext)
-> IO AVFormatContext
forall a b. (a -> b) -> a -> b
$ \ocTmp :: Ptr AVFormatContext
ocTmp -> do
          CInt
r <- String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
fname ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \fname' :: CString
fname' ->
                 (CString -> IO CInt) -> IO CInt
forall a. (CString -> IO a) -> IO a
withFormat ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \format :: CString
format ->
                   Ptr AVFormatContext
-> AVOutputFormat -> CString -> CString -> IO CInt
avformat_alloc_output_context2
                     Ptr AVFormatContext
ocTmp (Ptr () -> AVOutputFormat
AVOutputFormat Ptr ()
forall a. Ptr a
nullPtr)
                     CString
format CString
fname'
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0)
               (String -> IO ()
forall a. HasCallStack => String -> a
error "Couldn't allocate output format context")
          Ptr AVFormatContext -> IO AVFormatContext
forall a. Storable a => Ptr a -> IO a
peek Ptr AVFormatContext
ocTmp
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AVFormatContext -> Ptr ()
forall a. HasPtr a => a -> Ptr ()
getPtr AVFormatContext
oc Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
forall a. Ptr a
nullPtr)
       (String -> IO ()
forall a. HasCallStack => String -> a
error "Couldn't allocate output AVFormatContext")
  AVFormatContext -> IO AVFormatContext
forall (m :: * -> *) a. Monad m => a -> m a
return AVFormatContext
oc

-- | Open the given file for writing.
avio_open_check :: AVFormatContext -> String -> IO ()
avio_open_check :: AVFormatContext -> String -> IO ()
avio_open_check oc :: AVFormatContext
oc fname :: String
fname =
  do CInt
r <- String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
fname ((CString -> IO CInt) -> IO CInt)
-> (CString -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \cstr :: CString
cstr ->
            Ptr AVIOContext -> CString -> AVIOFlag -> IO CInt
avio_open (AVFormatContext -> Ptr AVIOContext
forall t. HasIOContext t => t -> Ptr AVIOContext
hasIOContext AVFormatContext
oc) CString
cstr AVIOFlag
avioFlagWrite
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall a. HasCallStack => String -> a
error "Error opening IO for writing")

-- | Close an open IO context.
avio_close_check :: AVFormatContext -> IO ()
avio_close_check :: AVFormatContext -> IO ()
avio_close_check oc :: AVFormatContext
oc = do CInt
r <- AVFormatContext -> IO AVIOContext
forall t. HasIOContext t => t -> IO AVIOContext
getIOContext AVFormatContext
oc IO AVIOContext -> (AVIOContext -> IO CInt) -> IO CInt
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AVIOContext -> IO CInt
avio_close
                         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) (String -> IO ()
forall a. HasCallStack => String -> a
error "Error closing IO")

-- | Returns 'True' if the 'AVPacket' was updated with new output
-- data; 'False' otherwise.
encode_video_check :: AVCodecContext -> AVPacket -> Maybe AVFrame -> IO Bool
encode_video_check :: AVCodecContext -> AVPacket -> Maybe AVFrame -> IO Bool
encode_video_check ctx :: AVCodecContext
ctx pkt :: AVPacket
pkt frame :: Maybe AVFrame
frame =
  (Ptr CInt -> IO Bool) -> IO Bool
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CInt -> IO Bool) -> IO Bool)
-> (Ptr CInt -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \gotOutput :: Ptr CInt
gotOutput -> do
    CInt
r <- AVCodecContext -> AVPacket -> AVFrame -> Ptr CInt -> IO CInt
avcodec_encode_video2 AVCodecContext
ctx AVPacket
pkt AVFrame
frame' Ptr CInt
gotOutput
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall a. HasCallStack => String -> a
error "Error encoding frame")
    (CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> 0) (CInt -> Bool) -> IO CInt -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr CInt -> IO CInt
forall a. Storable a => Ptr a -> IO a
peek Ptr CInt
gotOutput
  where frame' :: AVFrame
frame' = AVFrame -> Maybe AVFrame -> AVFrame
forall a. a -> Maybe a -> a
fromMaybe (Ptr () -> AVFrame
AVFrame Ptr ()
forall a. Ptr a
nullPtr) Maybe AVFrame
frame

-- | Allocate the stream private data and write the stream header to
-- an output media file.
write_header_check :: AVFormatContext -> IO ()
write_header_check :: AVFormatContext -> IO ()
write_header_check oc :: AVFormatContext
oc = do CInt
r <- AVFormatContext -> Ptr AVDictionary -> IO CInt
avformat_write_header AVFormatContext
oc Ptr AVDictionary
forall a. Ptr a
nullPtr
                           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall a. HasCallStack => String -> a
error "Error writing header")

-- | Write a packet to an output media file.
write_frame_check :: AVFormatContext -> AVPacket -> IO ()
write_frame_check :: AVFormatContext -> AVPacket -> IO ()
write_frame_check oc :: AVFormatContext
oc pkt :: AVPacket
pkt = do CInt
r <- AVFormatContext -> AVPacket -> IO CInt
av_write_frame AVFormatContext
oc AVPacket
pkt
                              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (String -> IO ()
forall a. HasCallStack => String -> a
error "Error writing frame")

-- | Write the stream trailer to an output media file and free the
-- private data. May only be called after a successful call to
-- 'write_header_check'.
write_trailer_check :: AVFormatContext -> IO ()
write_trailer_check :: AVFormatContext -> IO ()
write_trailer_check oc :: AVFormatContext
oc = do CInt
r <- AVFormatContext -> IO CInt
av_write_trailer AVFormatContext
oc
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0) (String -> IO ()
forall a. HasCallStack => String -> a
error "Error writing trailer")

-- | 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 :: EncodingParams -> Vector CUChar -> Vector CUChar
palettizeRGB8 ep :: EncodingParams
ep = \pix :: Vector CUChar
pix -> (forall s. ST s (MVector s CUChar)) -> Vector CUChar
forall a. Storable a => (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s CUChar)) -> Vector CUChar)
-> (forall s. ST s (MVector s CUChar)) -> Vector CUChar
forall a b. (a -> b) -> a -> b
$
  do let pix' :: Vector (V3 CUChar)
pix' = Vector CUChar -> Vector (V3 CUChar)
forall a b. (Storable a, Storable b) => Vector a -> Vector b
V.unsafeCast Vector CUChar
pix :: V.Vector (V3 CUChar)
     MVector s CUChar
m <- Int -> ST s (MVector (PrimState (ST s)) CUChar)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
VM.new (Int
numPix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1024)
     (Int -> ST s ()) -> Vector Int -> ST s ()
forall (m :: * -> *) a b.
(Monad m, Storable a) =>
(a -> m b) -> Vector a -> m ()
V.mapM_ (\i :: Int
i -> let p :: CUChar
p = V3 CInt -> CUChar
searchPal (V3 CInt -> CUChar) -> V3 CInt -> CUChar
forall a b. (a -> b) -> a -> b
$ CUChar -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CUChar -> CInt) -> V3 CUChar -> V3 CInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Vector (V3 CUChar)
pix' Vector (V3 CUChar) -> Int -> V3 CUChar
forall a. Storable a => Vector a -> Int -> a
V.! Int
i)
                    in MVector (PrimState (ST s)) CUChar -> Int -> CUChar -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.unsafeWrite MVector s CUChar
MVector (PrimState (ST s)) CUChar
m Int
i CUChar
p)
             (Int -> Int -> Vector Int
forall a. (Storable a, Num a) => a -> Int -> Vector a
V.enumFromN 0 Int
numPix)
     MVector (PrimState (ST s)) CUChar -> CUChar -> ST s ()
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> a -> m ()
VM.set (Int -> Int -> MVector s CUChar -> MVector s CUChar
forall a s. Storable a => Int -> Int -> MVector s a -> MVector s a
VM.unsafeSlice Int
numPix 1024 MVector s CUChar
m) 0
     MVector s CUChar -> ST s (MVector s CUChar)
forall (m :: * -> *) a. Monad m => a -> m a
return MVector s CUChar
m
  where numPix :: Int
numPix = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ EncodingParams -> CInt
epWidth EncodingParams
ep CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* EncodingParams -> CInt
epHeight EncodingParams
ep
        pal :: V.Vector (V3 CInt)
        pal :: Vector (V3 CInt)
pal = Int -> (Int -> V3 CInt) -> Vector (V3 CInt)
forall a. Storable a => Int -> (Int -> a) -> Vector a
V.generate 256 ((Int -> V3 CInt) -> Vector (V3 CInt))
-> (Int -> V3 CInt) -> Vector (V3 CInt)
forall a b. (a -> b) -> a -> b
$ \i' :: Int
i' ->
                let i :: CInt
i = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i'
                in CInt -> CInt -> CInt -> V3 CInt
forall a. a -> a -> a -> V3 a
V3 ((CInt
i CInt -> Int -> CInt
forall a. Bits a => a -> Int -> a
`shiftR` 5) CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* 36)
                      (((CInt
i CInt -> Int -> CInt
forall a. Bits a => a -> Int -> a
`shiftR` 2) CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.&. 7) CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* 36)
                      ((CInt
i CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.&. 3) CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* 85)
        searchPal :: V3 CInt -> CUChar
searchPal = Int -> CUChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CUChar) -> (V3 CInt -> Int) -> V3 CInt -> CUChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((V3 CInt -> V3 CInt -> Ordering) -> Vector (V3 CInt) -> Int)
-> Vector (V3 CInt) -> (V3 CInt -> V3 CInt -> Ordering) -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip (V3 CInt -> V3 CInt -> Ordering) -> Vector (V3 CInt) -> Int
forall a. Storable a => (a -> a -> Ordering) -> Vector a -> Int
V.minIndexBy Vector (V3 CInt)
pal ((V3 CInt -> V3 CInt -> Ordering) -> Int)
-> (V3 CInt -> V3 CInt -> V3 CInt -> Ordering) -> V3 CInt -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V3 CInt -> CInt) -> V3 CInt -> V3 CInt -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((V3 CInt -> CInt) -> V3 CInt -> V3 CInt -> Ordering)
-> (V3 CInt -> V3 CInt -> CInt)
-> V3 CInt
-> V3 CInt
-> V3 CInt
-> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V3 CInt -> V3 CInt -> CInt
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 :: EncodingParams -> Vector CUChar -> Vector CUChar
palettizeJuicy ep :: EncodingParams
ep pix :: Vector CUChar
pix =
  let (pix' :: Image Pixel8
pix', pal :: Palette
pal) = PaletteOptions -> Palette -> (Image Pixel8, Palette)
palettize (PaletteCreationMethod -> Bool -> Int -> PaletteOptions
PaletteOptions PaletteCreationMethod
MedianMeanCut Bool
doDither 256)
                              (Vector (PixelBaseComponent PixelRGB8) -> Palette
forall a. Vector (PixelBaseComponent a) -> Image a
mkImage (Vector (PixelBaseComponent PixelRGB8) -> Palette)
-> Vector (PixelBaseComponent PixelRGB8) -> Palette
forall a b. (a -> b) -> a -> b
$ Vector CUChar -> Vector Pixel8
forall a b. (Storable a, Storable b) => Vector a -> Vector b
V.unsafeCast Vector CUChar
pix)
      pal' :: Vector (V4 CUChar)
pal' = (V3 CUChar -> V4 CUChar)
-> Vector (V3 CUChar) -> Vector (V4 CUChar)
forall a b.
(Storable a, Storable b) =>
(a -> b) -> Vector a -> Vector b
V.map (\(V3 r :: CUChar
r g :: CUChar
g b :: CUChar
b) -> CUChar -> CUChar -> CUChar -> CUChar -> V4 CUChar
forall a. a -> a -> a -> a -> V4 a
V4 CUChar
b CUChar
g CUChar
r (255::CUChar))
                   (Vector Pixel8 -> Vector (V3 CUChar)
forall a b. (Storable a, Storable b) => Vector a -> Vector b
V.unsafeCast (Vector Pixel8 -> Vector (V3 CUChar))
-> Vector Pixel8 -> Vector (V3 CUChar)
forall a b. (a -> b) -> a -> b
$ Palette -> Vector (PixelBaseComponent PixelRGB8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Palette
pal)
  in Vector Pixel8 -> Vector CUChar
forall a b. (Storable a, Storable b) => Vector a -> Vector b
V.unsafeCast (Image Pixel8 -> Vector (PixelBaseComponent Pixel8)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image Pixel8
pix') Vector CUChar -> Vector CUChar -> Vector CUChar
forall a. Storable a => Vector a -> Vector a -> Vector a
V.++ Vector (V4 CUChar) -> Vector CUChar
forall a b. (Storable a, Storable b) => Vector a -> Vector b
V.unsafeCast Vector (V4 CUChar)
pal'
  where mkImage :: Vector (PixelBaseComponent a) -> Image a
mkImage = Int -> Int -> Vector (PixelBaseComponent a) -> Image a
forall a. Int -> Int -> Vector (PixelBaseComponent a) -> Image a
Image (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ EncodingParams -> CInt
epWidth EncodingParams
ep) (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> CInt -> Int
forall a b. (a -> b) -> a -> b
$ EncodingParams -> CInt
epHeight EncodingParams
ep)
        doDither :: Bool
doDither = EncodingParams -> String
epPreset EncodingParams
ep String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "dither"

-- | Open a target file for writing a video stream. The function
-- 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.
--
-- 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 :: EncodingParams
-> String
-> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
frameWriter ep :: EncodingParams
ep fname :: String
fname = do
  AVFormatContext
oc <- Maybe String -> String -> IO AVFormatContext
allocOutputContext (EncodingParams -> Maybe String
epFormatName EncodingParams
ep) String
fname
  (st :: AVStream
st,ctx :: AVCodecContext
ctx) <- EncodingParams -> AVFormatContext -> IO (AVStream, AVCodecContext)
initStream EncodingParams
ep AVFormatContext
oc

  AVPixelFormat
dstFmt <- AVCodecContext -> IO AVPixelFormat
forall t. HasPixelFormat t => t -> IO AVPixelFormat
getPixelFormat AVCodecContext
ctx
  AVFrame
dstFrame <- EncodingParams -> AVPixelFormat -> IO AVFrame
initTempFrame EncodingParams
ep AVPixelFormat
dstFmt
  let dstInfo :: ImageInfo
dstInfo = CInt -> CInt -> AVPixelFormat -> ImageInfo
ImageInfo (EncodingParams -> CInt
epWidth EncodingParams
ep) (EncodingParams -> CInt
epHeight EncodingParams
ep) AVPixelFormat
dstFmt

  -- Initialize the scaler that we use to convert RGB -> dstFmt
  -- Note that libswscaler does not support Pal8 as an output format.
  Maybe (IORef SwsContext)
sws <- if AVPixelFormat
dstFmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
/= AVPixelFormat
avPixFmtPal8 Bool -> Bool -> Bool
&& AVPixelFormat
dstFmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
/= AVPixelFormat
avPixFmtRgb8
         then ImageInfo -> ImageInfo -> SwsAlgorithm -> IO SwsContext
swsInit (CInt -> CInt -> AVPixelFormat -> ImageInfo
ImageInfo (EncodingParams -> CInt
epWidth EncodingParams
ep) (EncodingParams -> CInt
epHeight EncodingParams
ep) AVPixelFormat
avPixFmtRgb24)
                      ImageInfo
dstInfo SwsAlgorithm
swsBilinear
              IO SwsContext
-> (SwsContext -> IO (Maybe (IORef SwsContext)))
-> IO (Maybe (IORef SwsContext))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IORef SwsContext -> Maybe (IORef SwsContext))
-> IO (IORef SwsContext) -> IO (Maybe (IORef SwsContext))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef SwsContext -> Maybe (IORef SwsContext)
forall a. a -> Maybe a
Just (IO (IORef SwsContext) -> IO (Maybe (IORef SwsContext)))
-> (SwsContext -> IO (IORef SwsContext))
-> SwsContext
-> IO (Maybe (IORef SwsContext))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SwsContext -> IO (IORef SwsContext)
forall a. a -> IO (IORef a)
newIORef
         else Maybe (IORef SwsContext) -> IO (Maybe (IORef SwsContext))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IORef SwsContext)
forall a. Maybe a
Nothing

  AVPacket
pkt <- Ptr () -> AVPacket
AVPacket (Ptr () -> AVPacket) -> IO (Ptr ()) -> IO AVPacket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CSize -> IO (Ptr ())
av_malloc (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
packetSize)
  AVPacket -> CLong -> IO ()
forall t. HasPts t => t -> CLong -> IO ()
setPts AVPacket
pkt 0

  CInt
stIndex <- AVStream -> IO CInt
forall t. HasStreamIndex t => t -> IO CInt
getStreamIndex AVStream
st
  AVFormatContext -> String -> IO ()
avio_open_check AVFormatContext
oc String
fname
  AVFormatContext -> IO ()
write_header_check AVFormatContext
oc

  -- Frame number ioref. We use this to determine whether we should
  -- increment the frame PTS; we only want to do this for frames after
  -- the first one since we want the first frame PTS to be zero.
  IORef Int
frameNum <- Int -> IO (IORef Int)
forall a. a -> IO (IORef a)
newIORef (0::Int)

  let framePeriod :: AVRational
framePeriod = CInt -> CInt -> AVRational
AVRational 1 (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ EncodingParams -> Int
epFps EncodingParams
ep)

  -- The stream time_base can be changed by the call to
  -- 'write_header_check', so we read it back here to establish a way
  -- of scaling the nominal, desired frame rate (given by
  -- 'framePeriod') to the stream's time_base.
  AVRational
tb <- AVStream -> IO AVRational
forall t. HasTimeBase t => t -> IO AVRational
getTimeBase AVStream
st

{-# LINE 360 "src/Codec/FFmpeg/Encode.hsc" #-}

  let checkPalCompat :: (AVPixelFormat, V2 CInt, c) -> Bool
checkPalCompat
        | AVPixelFormat
dstFmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
/= AVPixelFormat
avPixFmtPal8 Bool -> Bool -> Bool
&& AVPixelFormat
dstFmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
/= AVPixelFormat
avPixFmtRgb8 = Bool -> (AVPixelFormat, V2 CInt, c) -> Bool
forall a b. a -> b -> a
const Bool
True
        | Bool
otherwise = \(srcFmt :: AVPixelFormat
srcFmt, V2 srcW :: CInt
srcW srcH :: CInt
srcH, _) ->
                        AVPixelFormat
srcFmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtRgb24 Bool -> Bool -> Bool
&&
                        CInt
srcW CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== EncodingParams -> CInt
epWidth EncodingParams
ep Bool -> Bool -> Bool
&&
                        CInt
srcH CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== EncodingParams -> CInt
epHeight EncodingParams
ep

      palettizer :: Maybe (Vector CUChar -> Vector CUChar)
palettizer | AVPixelFormat
dstFmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtPal8 = (Vector CUChar -> Vector CUChar)
-> Maybe (Vector CUChar -> Vector CUChar)
forall a. a -> Maybe a
Just ((Vector CUChar -> Vector CUChar)
 -> Maybe (Vector CUChar -> Vector CUChar))
-> (Vector CUChar -> Vector CUChar)
-> Maybe (Vector CUChar -> Vector CUChar)
forall a b. (a -> b) -> a -> b
$ EncodingParams -> Vector CUChar -> Vector CUChar
palettizeJuicy EncodingParams
ep
                 | AVPixelFormat
dstFmt AVPixelFormat -> AVPixelFormat -> Bool
forall a. Eq a => a -> a -> Bool
== AVPixelFormat
avPixFmtRgb8 = (Vector CUChar -> Vector CUChar)
-> Maybe (Vector CUChar -> Vector CUChar)
forall a. a -> Maybe a
Just ((Vector CUChar -> Vector CUChar)
 -> Maybe (Vector CUChar -> Vector CUChar))
-> (Vector CUChar -> Vector CUChar)
-> Maybe (Vector CUChar -> Vector CUChar)
forall a b. (a -> b) -> a -> b
$ EncodingParams -> Vector CUChar -> Vector CUChar
palettizeRGB8 EncodingParams
ep
                 | Bool
otherwise =  Maybe (Vector CUChar -> Vector CUChar)
forall a. Maybe a
Nothing
      frameTime :: CLong
frameTime = CLong -> AVRational -> AVRational -> CLong
av_rescale_q 1 AVRational
framePeriod AVRational
tb
      resetPacket :: IO ()
resetPacket = do AVPacket -> IO ()
init_packet AVPacket
pkt
                       AVPacket -> Ptr () -> IO ()
forall t. HasData t => t -> Ptr () -> IO ()
setData AVPacket
pkt Ptr ()
forall a. Ptr a
nullPtr
                       AVPacket -> CInt -> IO ()
forall t. HasSize t => t -> CInt -> IO ()
setSize AVPacket
pkt 0
      writePacket :: IO ()
writePacket = do AVPacket -> CInt -> IO ()
forall t. HasStreamIndex t => t -> CInt -> IO ()
setStreamIndex AVPacket
pkt CInt
stIndex
                       AVFormatContext -> AVPacket -> IO ()
write_frame_check AVFormatContext
oc AVPacket
pkt

      copyDstData :: (a, b, Vector a) -> IO ()
copyDstData (_,_,pixels :: Vector a
pixels) =
        IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ())
-> ((Ptr a -> IO CInt) -> IO CInt) -> (Ptr a -> IO CInt) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> (Ptr a -> IO CInt) -> IO CInt
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
V.unsafeWith Vector a
pixels ((Ptr a -> IO CInt) -> IO ()) -> (Ptr a -> IO CInt) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr ->
          Ptr (Ptr CUChar)
-> Ptr CInt
-> Ptr CUChar
-> AVPixelFormat
-> CInt
-> CInt
-> CInt
-> IO CInt
av_image_fill_arrays (Ptr (Ptr ()) -> Ptr (Ptr CUChar)
forall a b. Ptr a -> Ptr b
castPtr (Ptr (Ptr ()) -> Ptr (Ptr CUChar))
-> Ptr (Ptr ()) -> Ptr (Ptr CUChar)
forall a b. (a -> b) -> a -> b
$ AVFrame -> Ptr (Ptr ())
forall t. HasData t => t -> Ptr (Ptr ())
hasData AVFrame
dstFrame)
                               (AVFrame -> Ptr CInt
forall t. HasLineSize t => t -> Ptr CInt
hasLineSize AVFrame
dstFrame)
                               (Ptr a -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr)
                               AVPixelFormat
dstFmt
                               (EncodingParams -> CInt
epWidth EncodingParams
ep)
                               (EncodingParams -> CInt
epHeight EncodingParams
ep)
                               1

      scaleToDst :: SwsContext -> src -> IO ()
scaleToDst sws' :: SwsContext
sws' img :: src
img = IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ SwsContext -> src -> AVFrame -> IO CInt
forall src dst.
(SwsCompatible src, SwsCompatible dst) =>
SwsContext -> src -> dst -> IO CInt
swsScale SwsContext
sws' src
img AVFrame
dstFrame
      fillDst :: Maybe SwsContext
-> (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
fillDst = ((AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
-> (SwsContext -> (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
-> Maybe SwsContext
-> (AVPixelFormat, V2 CInt, Vector CUChar)
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
forall a a b. Storable a => (a, b, Vector a) -> IO ()
copyDstData SwsContext -> (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
forall src. SwsCompatible src => SwsContext -> src -> IO ()
scaleToDst

      -- | Gets the PTS to be used for the current frame by reading the
      -- PTS from dstFrame. If the current frame is the first frame
      -- (zero), the existing timestamp is left unmodified. Otherwise it
      -- is incremented by frameTime.
      --
      -- This also increments the current frame number stored in the
      -- frameNum IORef so the caller needn't worry about it.
      getCurrentFrameTimestamp :: IO CLong
getCurrentFrameTimestamp = do
           Int
curFrame <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
frameNum
           CLong
ts <- case Int
curFrame Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 of
               True -> AVFrame -> IO CLong
forall t. HasPts t => t -> IO CLong
getPts AVFrame
dstFrame
               False -> (CLong -> CLong -> CLong
forall a. Num a => a -> a -> a
+ CLong
frameTime) (CLong -> CLong) -> IO CLong -> IO CLong
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AVFrame -> IO CLong
forall t. HasPts t => t -> IO CLong
getPts AVFrame
dstFrame
           IORef Int -> (Int -> Int) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef Int
frameNum (Int -> Int -> Int
forall a. Num a => a -> a -> a
+1)
           CLong -> IO CLong
forall (m :: * -> *) a. Monad m => a -> m a
return CLong
ts

{-# LINE 420 "src/Codec/FFmpeg/Encode.hsc" #-}
      addEncoded :: Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
addEncoded Nothing = do IO ()
resetPacket
                              AVCodecContext -> AVPacket -> Maybe AVFrame -> IO Bool
encode_video_check AVCodecContext
ctx AVPacket
pkt Maybe AVFrame
forall a. Maybe a
Nothing IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IO ()
writePacket IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
addEncoded Maybe (AVPixelFormat, V2 CInt, Vector CUChar)
forall a. Maybe a
Nothing)
      addEncoded (Just srcImg :: (AVPixelFormat, V2 CInt, Vector CUChar)
srcImg@(srcFmt :: AVPixelFormat
srcFmt, V2 srcW :: CInt
srcW srcH :: CInt
srcH, pixels :: Vector CUChar
pixels)) =
        do IO ()
resetPacket
           Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (AVPixelFormat, V2 CInt, Vector CUChar) -> Bool
forall c. (AVPixelFormat, V2 CInt, c) -> Bool
checkPalCompat (AVPixelFormat, V2 CInt, Vector CUChar)
srcImg)
                (String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                 [String] -> String
unlines [ "Palettized output requires source images to be the "
                         , "same resolution as the output video" ])
           let pixels' :: Vector CUChar
pixels' = Vector CUChar
-> ((Vector CUChar -> Vector CUChar) -> Vector CUChar)
-> Maybe (Vector CUChar -> Vector CUChar)
-> Vector CUChar
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Vector CUChar
pixels ((Vector CUChar -> Vector CUChar) -> Vector CUChar -> Vector CUChar
forall a b. (a -> b) -> a -> b
$ Vector CUChar -> Vector CUChar
forall a b. (Storable a, Storable b) => Vector a -> Vector b
V.unsafeCast Vector CUChar
pixels) Maybe (Vector CUChar -> Vector CUChar)
palettizer
           Maybe SwsContext
sws' <- Maybe (IORef SwsContext)
-> (IORef SwsContext -> IO SwsContext) -> IO (Maybe SwsContext)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe (IORef SwsContext)
sws ((IORef SwsContext -> IO SwsContext) -> IO (Maybe SwsContext))
-> (IORef SwsContext -> IO SwsContext) -> IO (Maybe SwsContext)
forall a b. (a -> b) -> a -> b
$ \sPtr :: IORef SwsContext
sPtr -> do
                     SwsContext
s <- IORef SwsContext -> IO SwsContext
forall a. IORef a -> IO a
readIORef IORef SwsContext
sPtr
                     SwsContext
s' <- SwsContext
-> ImageInfo -> ImageInfo -> SwsAlgorithm -> IO SwsContext
swsReset SwsContext
s (CInt -> CInt -> AVPixelFormat -> ImageInfo
ImageInfo CInt
srcW CInt
srcH AVPixelFormat
srcFmt) ImageInfo
dstInfo
                                    SwsAlgorithm
swsBilinear
                     IORef SwsContext -> SwsContext -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef SwsContext
sPtr SwsContext
s'
                     SwsContext -> IO SwsContext
forall (m :: * -> *) a. Monad m => a -> m a
return SwsContext
s'
           Maybe SwsContext
-> (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
fillDst Maybe SwsContext
sws' (AVPixelFormat
srcFmt, CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 CInt
srcW CInt
srcH, Vector CUChar
pixels')
           CLong
timeStamp <- IO CLong
getCurrentFrameTimestamp
           AVFrame -> CLong -> IO ()
forall t. HasPts t => t -> CLong -> IO ()
setPts AVFrame
dstFrame CLong
timeStamp
           AVCodecContext -> AVPacket -> Maybe AVFrame -> IO Bool
encode_video_check AVCodecContext
ctx AVPacket
pkt (AVFrame -> Maybe AVFrame
forall a. a -> Maybe a
Just AVFrame
dstFrame) IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Bool -> IO () -> IO ()) -> IO () -> Bool -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when IO ()
writePacket
           -- Make sure the GC hasn't clobbered our palettized pixel data
           let (fp :: ForeignPtr CUChar
fp,_,_) = Vector CUChar -> (ForeignPtr CUChar, Int, Int)
forall a. Storable a => Vector a -> (ForeignPtr a, Int, Int)
V.unsafeToForeignPtr Vector CUChar
pixels'
           ForeignPtr CUChar -> IO ()
forall a. ForeignPtr a -> IO ()
touchForeignPtr ForeignPtr CUChar
fp

{-# LINE 446 "src/Codec/FFmpeg/Encode.hsc" #-}
      addFrame :: Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
addFrame = Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
addEncoded

{-# LINE 448 "src/Codec/FFmpeg/Encode.hsc" #-}
      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 img@(Just _) = addFrame img
  (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
-> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ()
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 :: EncodingParams -> String -> IO (Maybe (Vector CUChar) -> IO ())
frameWriterRgb ep :: EncodingParams
ep f :: String
f = ((Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
-> (Maybe (Vector CUChar)
    -> Maybe (AVPixelFormat, V2 CInt, Vector CUChar))
-> Maybe (Vector CUChar)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector CUChar -> (AVPixelFormat, V2 CInt, Vector CUChar))
-> Maybe (Vector CUChar)
-> Maybe (AVPixelFormat, V2 CInt, Vector CUChar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Vector CUChar -> (AVPixelFormat, V2 CInt, Vector CUChar)
forall c. c -> (AVPixelFormat, V2 CInt, c)
aux) ((Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
 -> Maybe (Vector CUChar) -> IO ())
-> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
-> IO (Maybe (Vector CUChar) -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EncodingParams
-> String
-> IO (Maybe (AVPixelFormat, V2 CInt, Vector CUChar) -> IO ())
frameWriter EncodingParams
ep String
f
  where aux :: c -> (AVPixelFormat, V2 CInt, c)
aux pixels :: c
pixels = (AVPixelFormat
avPixFmtRgb24, CInt -> CInt -> V2 CInt
forall a. a -> a -> V2 a
V2 (EncodingParams -> CInt
epWidth EncodingParams
ep) (EncodingParams -> CInt
epHeight EncodingParams
ep), c
pixels)