{-# 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)
import Foreign.Ptr (castPtr, nullPtr, Ptr)
import Foreign.Storable (Storable(sizeOf))

data ImageInfo = ImageInfo { ImageInfo -> CInt
imgWidth  :: CInt
                           , ImageInfo -> CInt
imgHeight :: CInt
                           , ImageInfo -> AVPixelFormat
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 :: ImageInfo -> ImageInfo -> SwsAlgorithm -> IO SwsContext
swsInit = SwsContext
-> ImageInfo -> ImageInfo -> SwsAlgorithm -> IO SwsContext
swsReset (Ptr () -> SwsContext
SwsContext Ptr ()
forall a. Ptr a
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. See 'swsInit' for a
-- description of the arguments.
swsReset :: SwsContext -> ImageInfo -> ImageInfo -> SwsAlgorithm
         -> IO SwsContext
swsReset :: SwsContext
-> ImageInfo -> ImageInfo -> SwsAlgorithm -> IO SwsContext
swsReset ctx :: SwsContext
ctx src :: ImageInfo
src dst :: ImageInfo
dst alg :: SwsAlgorithm
alg = SwsContext
-> CInt
-> CInt
-> AVPixelFormat
-> CInt
-> CInt
-> AVPixelFormat
-> SwsAlgorithm
-> Ptr ()
-> Ptr ()
-> Ptr CDouble
-> IO SwsContext
sws_getCachedContext SwsContext
ctx
                             CInt
srcW CInt
srcH AVPixelFormat
srcFmt
                             CInt
dstW CInt
dstH AVPixelFormat
dstFmt
                             SwsAlgorithm
alg Ptr ()
forall a. Ptr a
nullPtr Ptr ()
forall a. Ptr a
nullPtr Ptr CDouble
forall a. Ptr a
nullPtr
  where ImageInfo srcW :: CInt
srcW srcH :: CInt
srcH srcFmt :: AVPixelFormat
srcFmt = ImageInfo
src
        ImageInfo dstW :: CInt
dstW dstH :: CInt
dstH dstFmt :: AVPixelFormat
dstFmt = ImageInfo
dst

-- | A common interface required of arguments to 'swsScale' (a higher
-- level wrapper for the 'sws_scale' function from @libswscale@).
class SwsCompatible a where
  swsPlanes :: a -> (Ptr (Ptr CUChar) -> IO r) -> IO r
  swsStrides :: a -> (Ptr CInt -> IO r) -> IO r
  sliceHeight :: a -> (CInt -> IO r) -> IO r

instance SwsCompatible AVFrame where
  swsPlanes :: AVFrame -> (Ptr (Ptr CUChar) -> IO r) -> IO r
swsPlanes frame :: AVFrame
frame k :: Ptr (Ptr CUChar) -> IO r
k = Ptr (Ptr CUChar) -> IO r
k (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
frame)
  swsStrides :: AVFrame -> (Ptr CInt -> IO r) -> IO r
swsStrides frame :: AVFrame
frame k :: Ptr CInt -> IO r
k = Ptr CInt -> IO r
k (AVFrame -> Ptr CInt
forall t. HasLineSize t => t -> Ptr CInt
hasLineSize AVFrame
frame)
  sliceHeight :: AVFrame -> (CInt -> IO r) -> IO r
sliceHeight frame :: AVFrame
frame k :: CInt -> IO r
k = AVFrame -> IO CInt
forall t. HasHeight t => t -> IO CInt
getHeight AVFrame
frame IO CInt -> (CInt -> IO r) -> IO r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CInt -> IO r
k

instance (Pixel a, Storable (PixelBaseComponent a))
  => SwsCompatible (Image a) where
  swsPlanes :: Image a -> (Ptr (Ptr CUChar) -> IO r) -> IO r
swsPlanes img :: Image a
img k :: Ptr (Ptr CUChar) -> IO r
k = Vector (PixelBaseComponent a)
-> (Ptr (PixelBaseComponent a) -> IO r) -> IO r
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
V.unsafeWith (Image a -> Vector (PixelBaseComponent a)
forall a. Image a -> Vector (PixelBaseComponent a)
imageData Image a
img) ((Ptr (PixelBaseComponent a) -> IO r) -> IO r)
-> (Ptr (PixelBaseComponent a) -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr (PixelBaseComponent a)
ptr ->
                      [Ptr CUChar] -> (Ptr (Ptr CUChar) -> IO r) -> IO r
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray (Ptr (PixelBaseComponent a) -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr (PixelBaseComponent a)
ptr Ptr CUChar -> [Ptr CUChar] -> [Ptr CUChar]
forall a. a -> [a] -> [a]
: Int -> Ptr CUChar -> [Ptr CUChar]
forall a. Int -> a -> [a]
replicate 7 Ptr CUChar
forall a. Ptr a
nullPtr) Ptr (Ptr CUChar) -> IO r
k
  swsStrides :: Image a -> (Ptr CInt -> IO r) -> IO r
swsStrides img :: Image a
img k :: Ptr CInt -> IO r
k = [CInt] -> (Ptr CInt -> IO r) -> IO r
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray (CInt
stride CInt -> [CInt] -> [CInt]
forall a. a -> [a] -> [a]
: Int -> CInt -> [CInt]
forall a. Int -> a -> [a]
replicate 7 0) Ptr CInt -> IO r
k
    where sz :: Int
sz = PixelBaseComponent a -> Int
forall a. Storable a => a -> Int
sizeOf (PixelBaseComponent a
forall a. HasCallStack => a
undefined::PixelBaseComponent a) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 
               a -> Int
forall a. Pixel a => a -> Int
componentCount (a
forall a. HasCallStack => a
undefined :: a)
          stride :: CInt
stride = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Image a -> Int
forall a. Image a -> Int
imageWidth Image a
img Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
sz
  sliceHeight :: Image a -> (CInt -> IO r) -> IO r
sliceHeight img :: Image a
img k :: CInt -> IO r
k = CInt -> IO r
k (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ Image a -> Int
forall a. Image a -> Int
imageHeight Image a
img)

instance SwsCompatible (AVPixelFormat, V2 CInt, V.Vector CUChar) where
  swsPlanes :: (AVPixelFormat, V2 CInt, Vector CUChar)
-> (Ptr (Ptr CUChar) -> IO r) -> IO r
swsPlanes (_,_,p :: Vector CUChar
p) k :: Ptr (Ptr CUChar) -> IO r
k = Vector CUChar -> (Ptr CUChar -> IO r) -> IO r
forall a b. Storable a => Vector a -> (Ptr a -> IO b) -> IO b
V.unsafeWith Vector CUChar
p ((Ptr CUChar -> IO r) -> IO r) -> (Ptr CUChar -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr CUChar
ptr ->
                          [Ptr CUChar] -> (Ptr (Ptr CUChar) -> IO r) -> IO r
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray (Ptr CUChar -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr Ptr CUChar
ptr Ptr CUChar -> [Ptr CUChar] -> [Ptr CUChar]
forall a. a -> [a] -> [a]
: Int -> Ptr CUChar -> [Ptr CUChar]
forall a. Int -> a -> [a]
replicate 7 Ptr CUChar
forall a. Ptr a
nullPtr) Ptr (Ptr CUChar) -> IO r
k
  swsStrides :: (AVPixelFormat, V2 CInt, Vector CUChar)
-> (Ptr CInt -> IO r) -> IO r
swsStrides (fmt :: AVPixelFormat
fmt, V2 w :: CInt
w _, _) k :: Ptr CInt -> IO r
k = [CInt] -> (Ptr CInt -> IO r) -> IO r
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray (CInt
stride CInt -> [CInt] -> [CInt]
forall a. a -> [a] -> [a]
: Int -> CInt -> [CInt]
forall a. Int -> a -> [a]
replicate 7 0) Ptr CInt -> IO r
k
    where sz :: Int
sz = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Int
forall a. HasCallStack => [Char] -> a
error ([Char] -> Int) -> [Char] -> Int
forall a b. (a -> b) -> a -> b
$ "Unknown pixel stride for format "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++AVPixelFormat -> [Char]
forall a. Show a => a -> [Char]
show AVPixelFormat
fmt)
                         (AVPixelFormat -> Maybe Int
avPixelStride AVPixelFormat
fmt)
          stride :: CInt
stride = CInt
w CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
* Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz
  sliceHeight :: (AVPixelFormat, V2 CInt, Vector CUChar) -> (CInt -> IO r) -> IO r
sliceHeight (_, V2 _ h :: CInt
h, _) k :: CInt -> IO r
k = CInt -> IO r
k CInt
h

-- | Supplies a continuation with all components provided by the
-- 'SwsCompatible' class.
withSws :: SwsCompatible a
        => a -> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO r) -> IO r
withSws :: a -> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO r) -> IO r
withSws img :: a
img k :: Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO r
k = a -> (Ptr (Ptr CUChar) -> IO r) -> IO r
forall a r.
SwsCompatible a =>
a -> (Ptr (Ptr CUChar) -> IO r) -> IO r
swsPlanes a
img ((Ptr (Ptr CUChar) -> IO r) -> IO r)
-> (Ptr (Ptr CUChar) -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \planes :: Ptr (Ptr CUChar)
planes ->
                  a -> (Ptr CInt -> IO r) -> IO r
forall a r. SwsCompatible a => a -> (Ptr CInt -> IO r) -> IO r
swsStrides a
img ((Ptr CInt -> IO r) -> IO r) -> (Ptr CInt -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \strides :: Ptr CInt
strides ->
                    a -> (CInt -> IO r) -> IO r
forall a r. SwsCompatible a => a -> (CInt -> IO r) -> IO r
sliceHeight a
img ((CInt -> IO r) -> IO r) -> (CInt -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \height :: CInt
height ->
                      Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO r
k Ptr (Ptr CUChar)
planes Ptr CInt
strides CInt
height
                        
-- | @swsScale ctx src dst@ scales the entire @src@ image to @dst@
-- using the previously initialized @ctx@.
swsScale :: (SwsCompatible src, SwsCompatible dst)
         => SwsContext -> src -> dst -> IO CInt
swsScale :: SwsContext -> src -> dst -> IO CInt
swsScale ctx :: SwsContext
ctx src :: src
src dst :: dst
dst = src -> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO CInt) -> IO CInt
forall a r.
SwsCompatible a =>
a -> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO r) -> IO r
withSws src
src ((Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO CInt) -> IO CInt)
-> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \srcPlanes :: Ptr (Ptr CUChar)
srcPlanes srcStrides :: Ptr CInt
srcStrides srcHeight :: CInt
srcHeight ->
                         dst -> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO CInt) -> IO CInt
forall a r.
SwsCompatible a =>
a -> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO r) -> IO r
withSws dst
dst ((Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO CInt) -> IO CInt)
-> (Ptr (Ptr CUChar) -> Ptr CInt -> CInt -> IO CInt) -> IO CInt
forall a b. (a -> b) -> a -> b
$ \dstPlanes :: Ptr (Ptr CUChar)
dstPlanes dstStrides :: Ptr CInt
dstStrides _ ->
                           SwsContext
-> Ptr (Ptr CUChar)
-> Ptr CInt
-> CInt
-> CInt
-> Ptr (Ptr CUChar)
-> Ptr CInt
-> IO CInt
sws_scale SwsContext
ctx Ptr (Ptr CUChar)
srcPlanes Ptr CInt
srcStrides
                                     0 CInt
srcHeight
                                     Ptr (Ptr CUChar)
dstPlanes Ptr CInt
dstStrides