v4l2-examples 0.1 → 0.1.0.2
raw patch · 4 files changed
+217/−287 lines, 4 filesdep +GLUTdep +v4l2dep −bindings-libv4l2dep −bindings-linux-videodev2dep −bindings-mmapnew-component:exe:v4l2-histogram
Dependencies added: GLUT, v4l2
Dependencies removed: bindings-libv4l2, bindings-linux-videodev2, bindings-mmap, bindings-posix, c-io, ioctl
Files
- src/v4l2-capture.hs +0/−271
- v4l2-capture/v4l2-capture.hs +56/−0
- v4l2-examples.cabal +18/−16
- v4l2-histogram/v4l2-histogram.hs +143/−0
− src/v4l2-capture.hs
@@ -1,271 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface #-}--{- Loosely based on: v4l-capture.c--/*- * V4L2 video capture example- *- * This program can be used and distributed without restrictions.- *- * This program is provided with the V4L2 API- * see http://linuxtv.org/docs.php for more information- */-- This version writes YUYV frames on stdout in YUV4MPEG2 format.- Example usage:- $ ./v4l2-capture |- y4mscaler -I ilace=none -I sar=1/1 -O chromass=420mpeg2 |- mplayer -demuxer y4m - -vo x11-- TODO: this code is hella stinky, needs major work...---}--import Prelude hiding (catch)-import System.Exit (exitFailure)-import Bindings.Linux.VideoDev2-import Bindings.LibV4L2-import Bindings.MMap-import System.C.IO-import System.Posix.IOCtl (IOControl(..))-import System.Posix.Types (Fd(Fd))-import Bindings.Posix.Sys.Select (c'FD_ZERO, c'FD_SET, c'select)-import qualified Bindings.Posix.Sys.Select as P-import Foreign-import Foreign.C-import Control.Exception-import GHC.Conc (threadDelay)-import GHC.IO.Exception (IOErrorType(ResourceExhausted), ioe_type)-import System.Environment (getArgs)-import System.IO (hPutBuf, stderr, stdout, hFlush, hPutStr)-import Control.Monad (forM, forM_, replicateM, when)-import Data.Typeable (Typeable)--writeFrames :: Bool-writeFrames = True--data Mode = Read | MMap | UserPtr--data V4L2 = V4L2- { getFd :: IO Fd- , getWidth :: IO Word32- , getHeight :: IO Word32- , nextFrame :: (Ptr Word8 -> Int -> IO ()) -> IO ()- , finish :: IO ()- }--data V4L2Exception = V4L2NoCapture | V4L2NoRead | V4L2NoStream | V4L2NoBuffers | V4L2NoMMap- deriving (Show, Typeable)-instance Exception V4L2Exception--v4l2 :: Mode -> FilePath -> IO V4L2-v4l2 mode device = do- fdi <- withCString device $ \dev -> c'v4l2_open dev 2050 0 -- (c'O_RDWR .|. c'O_NONBLOCK) -- FIXME- let fdfi = fromIntegral fdi- fd = Fd fdfi- cap <- ioctl fd C'VIDIOC_QUERYCAP =<< empty- when (c'v4l2_capability'capabilities cap .&. c'V4L2_CAP_VIDEO_CAPTURE == 0) $ throwIO V4L2NoCapture- case mode of- Read -> when (c'v4l2_capability'capabilities cap .&. c'V4L2_CAP_READWRITE == 0) $ throwIO V4L2NoRead- _ -> when (c'v4l2_capability'capabilities cap .&. c'V4L2_CAP_STREAMING == 0) $ throwIO V4L2NoStream- (do- cropcap <- ioctl fd C'VIDIOC_CROPCAP . (\e -> e- { c'v4l2_cropcap'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE }) =<< empty- ioctl_ fd C'VIDIOC_S_CROP . (\e -> e- { c'v4l2_crop'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE- , c'v4l2_crop'c = c'v4l2_cropcap'defrect cropcap }) =<< empty- ) `catchIO` \_ -> return ()- pix0 <- return . (\e -> e- { c'v4l2_pix_format'width = 320- , c'v4l2_pix_format'height = 240- , c'v4l2_pix_format'pixelformat = c'V4L2_PIX_FMT_YUYV- , c'v4l2_pix_format'field = c'V4L2_FIELD_INTERLACED }) =<< empty- pix1 <- (`u'v4l2_format_u'pix` pix0) =<< empty- ioctl_ fd C'VIDIOC_S_FMT . (\e -> e- { c'v4l2_format'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE- , c'v4l2_format'fmt = pix1 }) =<< empty- fmt <- ioctl fd C'VIDIOC_G_FMT . (\e -> e- { c'v4l2_format'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE }) =<< empty- let pix = c'v4l2_format_u'pix . c'v4l2_format'fmt $ fmt- w = c'v4l2_pix_format'width pix- h = c'v4l2_pix_format'height pix- bytes = fromIntegral $ c'v4l2_pix_format'sizeimage pix- case mode of- Read -> do- buffer <- mallocBytes bytes- return V4L2- { getFd = return fd- , getWidth = return w- , getHeight = return h- , nextFrame = \f -> do- throwErrnoIfMinus1_ "read" $ cread (fromIntegral fd) buffer bytes- f buffer bytes- , finish = do- free buffer- throwErrnoIfMinus1_ "close" $ c'v4l2_close fdi- }- MMap -> do- req <- ioctl fd C'VIDIOC_REQBUFS . (\e -> e- { c'v4l2_requestbuffers'count = 4- , c'v4l2_requestbuffers'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE- , c'v4l2_requestbuffers'memory = c'V4L2_MEMORY_MMAP }) =<< empty- let nbuffers = c'v4l2_requestbuffers'count req- when (nbuffers < 2) $ throwIO $ V4L2NoBuffers- buffers <- forM [0 .. nbuffers-1] $ \n -> do- buf <- ioctl fd C'VIDIOC_QUERYBUF . (\e -> e- { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE- , c'v4l2_buffer'memory = c'V4L2_MEMORY_MMAP- , c'v4l2_buffer'index = n }) =<< empty- let len = fromIntegral $ c'v4l2_buffer'length buf- ptr <- c'mmap nullPtr len (c'PROT_READ .|. c'PROT_WRITE) c'MAP_SHARED fdfi (fromIntegral . c'v4l2_buffer_u'offset . c'v4l2_buffer'u $ buf)- when (ptr == p'MAP_FAILED) $ throwIO V4L2NoMMap- return (ptr, len)- forM_ (buffers `zip` [0 ..]) $ \(_, i) -> do- ioctl_ fd C'VIDIOC_QBUF . (\e -> e- { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE- , c'v4l2_buffer'memory = c'V4L2_MEMORY_MMAP- , c'v4l2_buffer'index = i }) =<< empty- ioctl_ fd C'VIDIOC_STREAMON c'V4L2_BUF_TYPE_VIDEO_CAPTURE- return V4L2- { getFd = return fd- , getWidth = return w- , getHeight = return h- , nextFrame = \f -> do- buf <- ioctl fd C'VIDIOC_DQBUF . (\e -> e- { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE- , c'v4l2_buffer'memory = c'V4L2_MEMORY_MMAP }) =<< empty- let (ptr, len) = (fst $ buffers !! fromIntegral (c'v4l2_buffer'index buf), c'v4l2_buffer'bytesused buf)- f (castPtr ptr) (fromIntegral len)- ioctl_ fd C'VIDIOC_QBUF buf- , finish = do- ioctl_ fd C'VIDIOC_STREAMOFF c'V4L2_BUF_TYPE_VIDEO_CAPTURE- forM_ buffers $ \(ptr, len) -> do- throwErrnoIfMinus1_ "munmap" $ c'munmap ptr len- throwErrnoIfMinus1_ "close" $ c'v4l2_close fdi- }- UserPtr -> do- ioctl_ fd C'VIDIOC_REQBUFS . (\e -> e- { c'v4l2_requestbuffers'count = 4- , c'v4l2_requestbuffers'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE- , c'v4l2_requestbuffers'memory = c'V4L2_MEMORY_USERPTR }) =<< empty- buffers <- replicateM 4 (mallocBytes bytes)- forM_ buffers $ \ptr -> do- u <- (\e -> u'v4l2_buffer_u'userptr e ({-unsafe-} fromIntegral (ptrToWordPtr ptr))) =<< empty- ioctl_ fd C'VIDIOC_QBUF . (\e -> e- { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE- , c'v4l2_buffer'memory = c'V4L2_MEMORY_USERPTR- , c'v4l2_buffer'u = u- , c'v4l2_buffer'length = fromIntegral bytes }) =<< empty- ioctl_ fd C'VIDIOC_STREAMON c'V4L2_BUF_TYPE_VIDEO_CAPTURE- return V4L2- { getFd = return fd- , getWidth = return w- , getHeight = return h- , nextFrame = \f -> do- buf <- ioctl fd C'VIDIOC_DQBUF . (\e -> e- { c'v4l2_buffer'type = c'V4L2_BUF_TYPE_VIDEO_CAPTURE- , c'v4l2_buffer'memory = c'V4L2_MEMORY_USERPTR }) =<< empty- let p = wordPtrToPtr . {-unsafe-} fromIntegral . c'v4l2_buffer_u'userptr . c'v4l2_buffer'u $ buf- f p (fromIntegral $ c'v4l2_buffer'bytesused buf)- ioctl_ fd C'VIDIOC_QBUF buf- , finish = do- -- FIXME- mapM_ free buffers- throwErrnoIfMinus1_ "close" $ c'v4l2_close fdi- }--empty :: Storable a => IO a-empty = do- alloca $ \p -> do- _ <- c'memset p 0 (fromIntegral $ sizeOf (unsafePerformIO (peek p)))- peek p--p'MAP_FAILED :: Ptr a-p'MAP_FAILED = intPtrToPtr c'MAP_FAILED--process_image :: V4L2 -> Ptr Word8 -> Int -> IO ()-process_image v4 p _size = do- when writeFrames $ do- w <- getWidth v4- h <- getHeight v4- putStrLn "FRAME"- allocaBytes (fromIntegral $ w * h) $ \y -> do- forM_ ([ 0, 2 .. fromIntegral $ w * h * 2 -1]`zip`[0..]) $ \(i, j) -> do- pokeElemOff y j =<< peekElemOff p i- hPutBuf stdout y (fromIntegral $ w * h)- allocaBytes (fromIntegral $ (w * h)) $ \u -> do- forM_ ([ 1, 5 .. fromIntegral $ w * h * 2 -1]`zip`[0..]) $ \(i, j) -> do- pokeElemOff u j =<< peekElemOff p i- hPutBuf stdout u (fromIntegral $ (w`div`2) * h)- allocaBytes (fromIntegral $ (w * h)) $ \v -> do- forM_ ([ 3, 7 .. fromIntegral $ w * h * 2 -1 ]`zip`[0..]) $ \(i, j) -> do- pokeElemOff v j =<< peekElemOff p i- hPutBuf stdout v (fromIntegral $ (w`div`2) * h)- hFlush stderr- hPutStr stderr "."- hFlush stdout--main :: IO ()-main = do- (device:_) <- (++["/dev/video0"]) `fmap` getArgs- v <- v4l2 MMap device- when writeFrames $ do- w <- getWidth v- h <- getHeight v- putStrLn $ "YUV4MPEG2 W" ++ show w ++ " H" ++ show h ++ " C422"- mainLoopRetry v (process_image v)- hPutStr stderr "\n"--mainLoopRetry :: V4L2 -> (Ptr Word8 -> Int -> IO ()) -> IO ()-mainLoopRetry v f = do- fd <- fromIntegral `fmap` getFd v- alloca $ \fds -> do- c'FD_ZERO fds- c'FD_SET fd fds- with P.C'timeval{ P.c'timeval'tv_sec = 5, P.c'timeval'tv_usec = 0 } $ \tv -> do- r <- c'select (fd + 1) fds nullPtr nullPtr tv- e <- getErrno- if r == -1 && e == eINTR- then mainLoopRetry v f- else if r > 0- then do- nextFrame v f `catch` \ex -> case ioe_type ex of- ResourceExhausted -> threadDelay 100000 >> mainLoopRetry v f- _ -> exitFailure- mainLoopRetry v f- else return ()--foreign import ccall "string.h memset" c'memset :: Ptr a -> CInt -> CSize -> IO (Ptr a)--catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = catch----foreign import ccall "fcntl.h open" --c_ioctl' :: IOControl req d => Fd -> req -> Ptr d -> IO ()-c_ioctl' f req p = throwErrnoIfMinus1_ "ioctl" $ c'v4l2_ioctl (fromIntegral f) (fromIntegral $ ioctlReq req) (castPtr p)---- | Calls a ioctl reading the structure after the call-ioctl :: IOControl req d- => Fd -- ^ The file descriptor - -> req -- ^ The request- -> d -- ^ The data- -> IO d -- ^ The data after the call-ioctl f req d = with d $ \p -> c_ioctl' f req p >> peek p---- | Call a ioctl ignoring the result-ioctl_ :: IOControl req d- => Fd -- ^ The file descriptor- -> req -- ^ The request- -> d -- ^ The data- -> IO ()-ioctl_ f req d = with d $ \p -> c_ioctl' f req p--{---- | Call a ioctl with uninitialized data-ioctl' :: IOControl req d- => Fd -- ^ The file descriptor- -> req -- ^ The request- -> IO d -- ^ The data-ioctl' f req = alloca $ \p -> c_ioctl' f req p >> peek p--}
+ v4l2-capture/v4l2-capture.hs view
@@ -0,0 +1,56 @@+module Main (main) where++import Control.Monad (forM_, when)+import Foreign (Ptr)+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO (hPutBuf, hPutStr, hPutStrLn, stdout, stderr)+import System.IO.Error (tryIOError)+import GHC.IO.Exception (IOErrorType(Interrupted), ioe_type)++import Graphics.V4L2++main :: IO ()+main = do+ (devname, verbose) <- checkArgs =<< getArgs+ e <- tryIOError $ withDevice devname $ \d -> do+ f <- setFormat d Capture . (\f->f{ imagePixelFormat = PixelRGB24 }) =<< getFormat d Capture+ checkFormat f+ info $ "frame size: " ++ show (imageWidth f) ++ "x" ++ show (imageHeight f) ++ " pixels (" ++ show (imageSize f) ++ " bytes)"+ forM_ [(0 :: Int) ..] $ \i -> do+ withFrame d f $ \p n -> do+ if n == imageSize f+ then do+ when verbose $ do+ info $ "Frame number " ++ show i+ writePPM (imageWidth f) (imageHeight f) p+ else warn $ "incomplete frame (" ++ show n ++ " bytes, expected " ++ show (imageSize f) ++ " bytes)"+ case e of+ Left f | ioe_type f == Interrupted -> return ()+ | otherwise -> ioError f+ Right () -> return ()++writePPM :: Int -> Int -> Ptr a -> IO ()+writePPM w h p = do+ hPutStr stdout $ "P6\n" ++ show w ++ " " ++ show h ++ " 255\n"+ hPutBuf stdout p (w * h * 3)++checkFormat :: ImageFormat -> IO ()+checkFormat f = do+ when (imagePixelFormat f /= PixelRGB24) $ err "could not set RGB24 pixel format"+ when (imageBytesPerLine f /= imageWidth f * 3) $ err "cannot handle extra padding"+ when (imageSize f /= imageBytesPerLine f * imageHeight f) $ err "cannot handle image size"++-- TODO verbosity flag+checkArgs :: [String] -> IO (String, Bool)+checkArgs [devname] = return (devname, False)+checkArgs _ = err $ "bad arguments; usage: v4l2-capture /dev/video0"++err :: String -> IO a+err msg = (hPutStrLn stderr $ "**ERROR: [v4l2-capture] " ++ msg) >> exitFailure++warn :: String -> IO ()+warn msg = hPutStrLn stderr $ "++ WARN: [v4l2-capture] " ++ msg++info :: String -> IO ()+info msg = hPutStrLn stderr $ " INFO: [v4l2-capture] " ++ msg
v4l2-examples.cabal view
@@ -1,37 +1,39 @@ Name: v4l2-examples-Version: 0.1+Version: 0.1.0.2 Synopsis: video for linux two examples Description:- This package contains examples for accessing v4l2 from Haskell:+ This package contains examples using the v4l2 package: .- * v4l2-capture - dumps frames from a video device to stdout:+ * v4l2-capture - dumps PPM frames from a video device to stdout: .- @$ v4l2-capture |- y4mscaler -v0 -I ilace=none -I sar=1/1 -O chromass=420mpeg2 |- mplayer -demuxer y4m - -vo x11@+ @$ v4l2-capture /dev/video0 > out.ppm@ .- Currently low-level imperative code; but a mid-level v4l2 library is- planned which will make it less horrific.+ * v4l2-histogram - shows RGB histogram overlaid on mirror image, using OpenGL/GLUT for display.+ .+ @$ v4l2-histogram /dev/video0@ Homepage: https://gitorious.org/hsv4l2 License: BSD3 License-file: LICENSE Author: Claude Heiland-Allen-Maintainer: claudiusmaximus@goto10.org+Maintainer: claude@mathr.co.uk Category: Graphics Build-type: Simple Cabal-version: >=1.2 Executable v4l2-capture- Main-is: src/v4l2-capture.hs+ Main-is: v4l2-capture/v4l2-capture.hs Build-depends: base >= 3 && < 5,- bindings-libv4l2 >= 0.1 && < 0.2,- bindings-linux-videodev2 >= 0.1 && < 0.2,- bindings-mmap >= 0.1 && < 0.2,- bindings-posix >= 1.2 && < 1.3,- c-io >= 0.1 && < 0.2,- ioctl >= 0.0 && < 0.1+ v4l2 >= 0.1 && < 0.2+ ghc-options: -Wall++Executable v4l2-histogram+ Main-is: v4l2-histogram/v4l2-histogram.hs+ Build-depends:+ base >= 3 && < 5,+ GLUT >= 2.1 && < 2.4,+ v4l2 >= 0.1 && < 0.2 ghc-options: -Wall
+ v4l2-histogram/v4l2-histogram.hs view
@@ -0,0 +1,143 @@+module Main (main) where++import Prelude hiding (map, sum)++import Control.Monad (when)+import Data.Word (Word8, Word32)+import Foreign (Ptr, nullPtr, allocaArray, peekElemOff, pokeElemOff)+import System.Exit (exitFailure, exitSuccess)+import System.IO (hPutStrLn, stderr)++import Graphics.UI.GLUT hiding (PixelFormat, histogram, imageHeight)+import Graphics.V4L2++pixel :: PixelFormat+pixel = PixelRGB24++main :: IO ()+main = do+ initialWindowSize $= Size 640 480+ initialDisplayMode $= [DoubleBuffered]+ devname <- checkArgs . snd =<< getArgsAndInitialize+ withDevice devname $ \d -> do+ f <- setFormat d Capture . (\f->f{ imagePixelFormat = pixel }) =<< getFormat d Capture+ checkFormat f+ info $ "frame size: " ++ show (imageWidth f) ++ "x" ++ show (imageHeight f) ++ " pixels (" ++ show (imageSize f) ++ " bytes)"+ let (_, texSize:_) = break (>= (imageWidth f `max` imageHeight f)) $ iterate (2*) 1+ _ <- createWindow "v4l2-histogram"+ depthFunc $= Nothing+ texture Texture2D $= Enabled+ [th, ti] <- genObjectNames 2+ textureBinding Texture2D $= Just th+ texImage2D Nothing NoProxy 0 RGBA' (TextureSize2D 256 256) 0 (PixelData RGBA UnsignedByte nullPtr)+ textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+ textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+ textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+ textureBinding Texture2D $= Just ti+ texImage2D Nothing NoProxy 0 RGBA' (TextureSize2D (fromIntegral texSize) (fromIntegral texSize)) 0 (PixelData RGBA UnsignedByte nullPtr)+ textureFilter Texture2D $= ((Nearest, Nothing), Nearest)+ textureWrapMode Texture2D S $= (Repeated, ClampToEdge)+ textureWrapMode Texture2D T $= (Repeated, ClampToEdge)+ matrixMode $= Modelview 0+ loadIdentity+ matrixMode $= Projection+ loadIdentity+ ortho2D 0 1 1 0+ idleCallback $= Just (idle d f texSize ti th)+ displayCallback $= display d f texSize ti th+ keyboardMouseCallback $= Just (\_ _ _ _ -> exitSuccess)+ mainLoop++idle :: Device -> ImageFormat -> Int -> TextureObject -> TextureObject -> IO ()+idle d f _ ti th = withFrame d f $ \p n -> do+ if n == imageSize f+ then allocaArray (256 * 3) $ \h -> allocaArray (256 * 256 * 4) $ \q -> do+ histogram (imageWidth f * imageHeight f * 3) p h+ expand (fromIntegral $ imageWidth f * imageHeight f) h q+ textureBinding Texture2D $= Just ti+ texSubImage2D Nothing 0 (TexturePosition2D 0 0) (TextureSize2D (fromIntegral $ imageWidth f) (fromIntegral $ imageHeight f)) (PixelData RGB UnsignedByte p)+ textureBinding Texture2D $= Just th+ texSubImage2D Nothing 0 (TexturePosition2D 0 0) (TextureSize2D 256 256) (PixelData RGBA UnsignedByte q)+ postRedisplay Nothing + else warn $ "incomplete frame (" ++ show n ++ " bytes, expected " ++ show (imageSize f) ++ " bytes)"++display:: Device -> ImageFormat -> Int -> TextureObject -> TextureObject -> IO ()+display _ f texSize ti th = do+ textureBinding Texture2D $= Just ti+ renderPrimitive Quads (u 0 0 >> u 0 1 >> u 1 1 >> u 1 0)+ blend $= Enabled+ blendFunc $= (SrcAlpha, OneMinusSrcAlpha)+ textureBinding Texture2D $= Just th+ renderPrimitive Quads (v 0 0 >> v 0 1 >> v 1 1 >> v 1 0)+ blend $= Disabled+ swapBuffers+ where+ u :: GLfloat -> GLfloat -> IO ()+ u x y = texCoord (TexCoord2 (x * fromIntegral (imageWidth f) / fromIntegral texSize) (y * fromIntegral (imageHeight f) / fromIntegral texSize)) >> vertex (Vertex2 (1 - x) y)+ v :: GLfloat -> GLfloat -> IO ()+ v x y = texCoord (TexCoord2 x y) >> vertex (Vertex2 x y)++histogram :: Int -> Ptr Word8 -> Ptr Word32 -> IO ()+histogram m p q = c 0 >> h 0 >> h 1 >> h 2+ where+ c i | i >= 256 * 3 = return ()+ | otherwise = do+ pokeElemOff q i 0+ c (i + 1)+ h i0 = h' i0+ where+ h' i | i >= m = return ()+ | otherwise = do+ j <- peekElemOff p i+ let j' = fromIntegral j * 3 + i0+ t <- peekElemOff q j'+ pokeElemOff q j' (t + 1)+ h' (i + 3)++expand :: Float -> Ptr Word32 -> Ptr Word8 -> IO ()+expand m p q = e 0 >> a 0+ where+ e i | i >= 256 = return ()+ | otherwise = e' 0 >> e' 1 >> e' 2 >> e (i + 1)+ where+ e' c = do+ s <- peekElemOff p (3 * i + c)+ let t | s == 0 = 255+ | otherwise = round . max 0 . min 255 $ 256 * log (m / fromIntegral s) / log 256+ f t+ where+ f t = g 0+ where+ g j | j == 256 = return ()+ | otherwise = do+ pokeElemOff q ((j * 256 + i) * 4 + c) $ if j > t then 255 else 0+ g (j + 1)+ a i | i >= 256 * 256 * 4 = return ()+ | otherwise = do+ r <- peekElemOff q i+ if r > 0 then pokeElemOff q (i + 3) 255 else do+ g <- peekElemOff q (i + 1)+ if g > 0 then pokeElemOff q (i + 3) 255 else do+ b <- peekElemOff q (i + 2)+ if b > 0 then pokeElemOff q (i + 3) 255 else do+ pokeElemOff q (i + 3) 0+ a (i + 4)++checkFormat :: ImageFormat -> IO ()+checkFormat f = do+ when (imagePixelFormat f /= pixel) $ err ("could not set pixel format " ++ show pixel)+ when (imageBytesPerLine f /= imageWidth f * 3) $ err "cannot handle extra padding"+ when (imageSize f /= imageBytesPerLine f * imageHeight f) $ err "cannot handle image size"++checkArgs :: [String] -> IO String+checkArgs [devname] = return devname+checkArgs _ = err $ "bad arguments; usage: v4l2-histogram /dev/video0"++err :: String -> IO a+err msg = (hPutStrLn stderr $ "**ERROR: [v4l2-histogram] " ++ msg) >> exitFailure++warn :: String -> IO ()+warn msg = hPutStrLn stderr $ "++ WARN: [v4l2-histogram] " ++ msg++info :: String -> IO ()+info msg = hPutStrLn stderr $ " INFO: [v4l2-histogram] " ++ msg