module Graphics.V4L2.Format
( BufferType(..)
, Direction(..)
, Format(..)
, FormatID()
, FormatDescription(..)
, FormatFlag(..)
, queryFormats
, FrameSize(..)
, FrameSizes(..)
, queryFrameSizes
, FrameIntervals(..)
, queryFrameIntervals
, ImageFormat(..)
) where
import Control.Exception as E (catch, throwIO)
import Control.Monad (when)
import Data.Data (Data)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Set (Set)
import qualified Data.Set as S
import Data.Typeable (Typeable)
import Data.Word (Word32)
import GHC.IO.Exception (IOErrorType(InvalidArgument), ioe_type)
import Bindings.Linux.VideoDev2
import Foreign.Extra.BitSet (fromBitSet)
import Foreign.Extra.CEnum (toCEnum)
import Foreign.Extra.String (fromString)
import Graphics.V4L2.Device (Device)
import Graphics.V4L2.IOCtl (ioctl, zero)
import Graphics.V4L2.Field (Field)
import Graphics.V4L2.Field.Internal (fromField, toField)
import Graphics.V4L2.PixelFormat (PixelFormat)
import Graphics.V4L2.PixelFormat.Internal (fromPixelFormat, toPixelFormat)
import Graphics.V4L2.ColorSpace (ColorSpace)
import Graphics.V4L2.ColorSpace.Internal (fromColorSpace, toColorSpace)
import Graphics.V4L2.Types (Fraction(..))
import Graphics.V4L2.Types.Internal (fromFraction)
data BufferType = BufferVideoCapture | BufferVideoOutput | BufferUnknown Word32
deriving (Eq, Ord, Read, Show, Data, Typeable)
toBufferType :: BufferType -> C'v4l2_buf_type
toBufferType = toCEnum
[ ( BufferVideoCapture , c'V4L2_BUF_TYPE_VIDEO_CAPTURE )
, ( BufferVideoOutput , c'V4L2_BUF_TYPE_VIDEO_OUTPUT )
] isU unU
where
isU (BufferUnknown _) = True
isU _ = False
unU (BufferUnknown b) = fromIntegral b
unU _ = error "err"
data Direction = Capture | Output
deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable)
class Format f where
formatBufferType :: f -> Direction -> BufferType
getFormat :: Device -> Direction -> IO f
setFormat :: Device -> Direction -> f -> IO f
tryFormat :: Device -> Direction -> f -> IO f
data ImageFormat = ImageFormat
{ imageWidth, imageHeight :: Int
, imagePixelFormat :: PixelFormat
, imageField :: Field
, imageBytesPerLine :: Int
, imageSize :: Int
, imageColorSpace :: ColorSpace
}
deriving (Eq, Ord, Read, Show, Data, Typeable)
instance Format ImageFormat where
formatBufferType _ = imageBufferType
getFormat d dir =
return . decodeImageFormat . c'v4l2_format_u'pix . c'v4l2_format'fmt =<< ioctl d C'VIDIOC_G_FMT . (\s->s{ c'v4l2_format'type = toBufferType $ imageBufferType dir }) =<< zero
setFormat d dir f = do
u <- (`u'v4l2_format_u'pix` encodeImageFormat f) =<< zero
return . decodeImageFormat . c'v4l2_format_u'pix . c'v4l2_format'fmt =<< ioctl d C'VIDIOC_S_FMT =<< (\s->s{ c'v4l2_format'type = toBufferType $ imageBufferType dir, c'v4l2_format'fmt = u }) `fmap` zero
tryFormat d dir f = do
u <- (`u'v4l2_format_u'pix` encodeImageFormat f) =<< zero
return . decodeImageFormat . c'v4l2_format_u'pix . c'v4l2_format'fmt =<< ioctl d C'VIDIOC_TRY_FMT =<< (\s->s{ c'v4l2_format'type = toBufferType $ imageBufferType dir, c'v4l2_format'fmt = u }) `fmap` zero
encodeImageFormat :: ImageFormat -> C'v4l2_pix_format
encodeImageFormat f = C'v4l2_pix_format
{ c'v4l2_pix_format'width = fromIntegral $ imageWidth f
, c'v4l2_pix_format'height = fromIntegral $ imageHeight f
, c'v4l2_pix_format'pixelformat = toPixelFormat $ imagePixelFormat f
, c'v4l2_pix_format'field = toField $ imageField f
, c'v4l2_pix_format'bytesperline = fromIntegral $ imageBytesPerLine f
, c'v4l2_pix_format'sizeimage = fromIntegral $ imageSize f
, c'v4l2_pix_format'colorspace = toColorSpace $ imageColorSpace f
, c'v4l2_pix_format'priv = 0
}
decodeImageFormat :: C'v4l2_pix_format -> ImageFormat
decodeImageFormat f = ImageFormat
{ imageWidth = fromIntegral $ c'v4l2_pix_format'width f
, imageHeight = fromIntegral $ c'v4l2_pix_format'height f
, imagePixelFormat = fromPixelFormat $ c'v4l2_pix_format'pixelformat f
, imageField = fromField $ c'v4l2_pix_format'field f
, imageBytesPerLine = fromIntegral $ c'v4l2_pix_format'bytesperline f
, imageSize = fromIntegral $ c'v4l2_pix_format'sizeimage f
, imageColorSpace = fromColorSpace $ c'v4l2_pix_format'colorspace f
}
imageBufferType :: Direction -> BufferType
imageBufferType Capture = BufferVideoCapture
imageBufferType Output = BufferVideoOutput
data FormatFlag
= FormatCompressed
| FormatEmulated
| FormatUnknown Word32
deriving (Eq, Ord, Read, Show, Data, Typeable)
fromFormatFlag :: Word32 -> Set FormatFlag
fromFormatFlag = fromBitSet
[ ( FormatCompressed , c'V4L2_FMT_FLAG_COMPRESSED )
, ( FormatEmulated , c'V4L2_FMT_FLAG_EMULATED )
] FormatUnknown
newtype FormatID = FormatID Int
deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Typeable, Num, Integral, Real)
data FormatDescription = FormatDescription
{ formatDescription :: String
, formatPixelFormat :: PixelFormat
, formatFlags :: Set FormatFlag
}
deriving (Eq, Ord, Read, Show, Data, Typeable)
enumfmt :: Device -> BufferType -> FormatID -> IO FormatDescription
enumfmt h t n = do
d <- ioctl h C'VIDIOC_ENUM_FMT . (\s->s{ c'v4l2_fmtdesc'index = fromIntegral n, c'v4l2_fmtdesc'type = toBufferType t }) =<< zero
return FormatDescription
{ formatDescription = fromString $ c'v4l2_fmtdesc'description d
, formatPixelFormat = fromPixelFormat $ c'v4l2_fmtdesc'pixelformat d
, formatFlags = fromFormatFlag $ c'v4l2_fmtdesc'flags d
}
queryFormats :: Device -> BufferType -> IO (Map FormatID FormatDescription)
queryFormats = enumfmts' 0
enumfmts' :: FormatID -> Device -> BufferType -> IO (Map FormatID FormatDescription)
enumfmts' n h t = do
mi <- (Just `fmap` enumfmt h t n) `E.catch` (\e -> case ioe_type e of
InvalidArgument -> return Nothing
_ -> throwIO e)
case mi of
Just i -> M.insert n i `fmap` enumfmts' (n + 1) h t
Nothing -> return M.empty
queryFrameSizes :: Device -> PixelFormat -> IO FrameSizes
queryFrameSizes h p = do
fs <- enumframesizes0 h p `E.catch` (\e -> case ioe_type e of
InvalidArgument -> return (DiscreteSizes S.empty)
_ -> throwIO e)
case fs of
DiscreteSizes f | not $ S.null f -> do
fs' <- enumframesizesD 1 h p
return . DiscreteSizes $ f `S.union` fs'
_ -> return fs
enumframesizes0 :: Device -> PixelFormat -> IO FrameSizes
enumframesizes0 h p = do
f <- ioctl h C'VIDIOC_ENUM_FRAMESIZES . (\s->s{ c'v4l2_frmsizeenum'index = 0, c'v4l2_frmsizeenum'pixel_format = toPixelFormat p }) =<< zero
case c'v4l2_frmsizeenum'type f of
x | x == c'V4L2_FRMSIZE_TYPE_DISCRETE -> return . DiscreteSizes . S.singleton . decodeFrameSize . c'v4l2_frmsizeenum_u'discrete . c'v4l2_frmsizeenum'u $ f
| x == c'V4L2_FRMSIZE_TYPE_STEPWISE ||
x == c'V4L2_FRMSIZE_TYPE_CONTINUOUS -> do
let s = c'v4l2_frmsizeenum_u'stepwise . c'v4l2_frmsizeenum'u $ f
return StepwiseSizes
{ stepwiseMinWidth = fromIntegral $ c'v4l2_frmsize_stepwise'min_width s
, stepwiseMaxWidth = fromIntegral $ c'v4l2_frmsize_stepwise'max_width s
, stepwiseStepWidth = fromIntegral $ c'v4l2_frmsize_stepwise'step_width s
, stepwiseMinHeight = fromIntegral $ c'v4l2_frmsize_stepwise'min_height s
, stepwiseMaxHeight = fromIntegral $ c'v4l2_frmsize_stepwise'max_height s
, stepwiseStepHeight = fromIntegral $ c'v4l2_frmsize_stepwise'step_height s
}
| otherwise -> error "err"
enumframesizesD :: Word32 -> Device -> PixelFormat -> IO (Set FrameSize)
enumframesizesD n h p = do
f <- (do
f' <- ioctl h C'VIDIOC_ENUM_FRAMESIZES . (\s->s{ c'v4l2_frmsizeenum'index = n, c'v4l2_frmsizeenum'pixel_format = toPixelFormat p }) =<< zero
when (c'v4l2_frmsizeenum'type f' /= c'V4L2_FRMSIZE_TYPE_DISCRETE) $ error "err"
return (Just f')) `E.catch` (\e -> case ioe_type e of
InvalidArgument -> return Nothing
_ -> throwIO e)
case f of
Nothing -> return S.empty
Just fs -> S.insert (decodeFrameSize . c'v4l2_frmsizeenum_u'discrete . c'v4l2_frmsizeenum'u $ fs) `fmap` enumframesizesD (n + 1) h p
data FrameSize = FrameSize
{ frameWidth
, frameHeight :: Int
}
deriving (Eq, Ord, Read, Show, Data, Typeable)
data FrameSizes
= DiscreteSizes
{ discreteSizes :: Set FrameSize }
| StepwiseSizes
{ stepwiseMinWidth
, stepwiseMaxWidth
, stepwiseStepWidth
, stepwiseMinHeight
, stepwiseMaxHeight
, stepwiseStepHeight :: Int
}
deriving (Eq, Ord, Read, Show, Data, Typeable)
decodeFrameSize :: C'v4l2_frmsize_discrete -> FrameSize
decodeFrameSize d = FrameSize
{ frameWidth = fromIntegral $ c'v4l2_frmsize_discrete'width d
, frameHeight = fromIntegral $ c'v4l2_frmsize_discrete'height d
}
queryFrameIntervals :: Device -> PixelFormat -> FrameSize -> IO FrameIntervals
queryFrameIntervals h p f = do
fi <- enumframeintervals0 h p f `E.catch` (\e -> case ioe_type e of
InvalidArgument -> return (DiscreteIntervals S.empty)
_ -> throwIO e)
case fi of
DiscreteIntervals i | not $ S.null i -> do
is <- enumframeintervalsD 1 h p f
return . DiscreteIntervals $ i `S.union` is
_ -> return fi
enumframeintervals0 :: Device -> PixelFormat -> FrameSize -> IO FrameIntervals
enumframeintervals0 h p f = do
i <- ioctl h C'VIDIOC_ENUM_FRAMEINTERVALS . (\s->s{ c'v4l2_frmivalenum'index = 0, c'v4l2_frmivalenum'pixel_format = toPixelFormat p, c'v4l2_frmivalenum'width = fromIntegral (frameWidth f), c'v4l2_frmivalenum'height = fromIntegral (frameHeight f) }) =<< zero
case c'v4l2_frmivalenum'type i of
x | x == c'V4L2_FRMIVAL_TYPE_DISCRETE -> return . DiscreteIntervals . S.singleton . fromFraction . c'v4l2_frmivalenum_u'discrete . c'v4l2_frmivalenum'u $ i
| x == c'V4L2_FRMIVAL_TYPE_STEPWISE ||
x == c'V4L2_FRMIVAL_TYPE_CONTINUOUS -> do
let s = c'v4l2_frmivalenum_u'stepwise . c'v4l2_frmivalenum'u $ i
return StepwiseIntervals
{ stepwiseMin = fromFraction $ c'v4l2_frmival_stepwise'min s
, stepwiseMax = fromFraction $ c'v4l2_frmival_stepwise'max s
, stepwiseStep = fromFraction $ c'v4l2_frmival_stepwise'step s
}
| otherwise -> error "err"
enumframeintervalsD :: Word32 -> Device -> PixelFormat -> FrameSize -> IO (Set Fraction)
enumframeintervalsD n h p f = do
i <- (do
f' <- ioctl h C'VIDIOC_ENUM_FRAMEINTERVALS . (\s->s{ c'v4l2_frmivalenum'index = n, c'v4l2_frmivalenum'pixel_format = toPixelFormat p, c'v4l2_frmivalenum'width = fromIntegral (frameWidth f), c'v4l2_frmivalenum'height = fromIntegral (frameHeight f) }) =<< zero
when (c'v4l2_frmivalenum'type f' /= c'V4L2_FRMIVAL_TYPE_DISCRETE) $ error "err"
return (Just f')) `E.catch` (\e -> case ioe_type e of
InvalidArgument -> return Nothing
_ -> throwIO e)
case i of
Nothing -> return S.empty
Just fs -> S.insert (fromFraction . c'v4l2_frmivalenum_u'discrete . c'v4l2_frmivalenum'u $ fs) `fmap` enumframeintervalsD (n + 1) h p f
data FrameIntervals
= DiscreteIntervals
{ discreteIntervals :: Set Fraction }
| StepwiseIntervals
{ stepwiseMin, stepwiseMax, stepwiseStep :: Fraction }
deriving (Eq, Ord, Read, Show, Data, Typeable)