-- GENERATED by C->Haskell Compiler, version 0.16.3 Crystal Seed, 24 Jan 2009 (Haskell)
-- Edit the ORIGNAL .chs file instead!


{-# LINE 1 "./CV/Video.chs" #-}{-#LANGUAGE ForeignFunctionInterface, ViewPatterns, CPP#-}
module CV.Video where
import CV.Image
{-# LINE 4 "./CV/Video.chs" #-}

import Foreign.Marshal.Array
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.String
import System.IO.Unsafe
import Utils.Stream

-- NOTE: For some reason, this module fails to work with ghci for me

newtype Capture = Capture (ForeignPtr (Capture))
withCapture (Capture fptr) = withForeignPtr fptr
{-# LINE 18 "./CV/Video.chs" #-}

foreign import ccall "& wrapReleaseCapture" releaseCapture :: FinalizerPtr Capture

newtype VideoWriter = VideoWriter (ForeignPtr (VideoWriter))
withVideoWriter (VideoWriter fptr) = withForeignPtr fptr
{-# LINE 22 "./CV/Video.chs" #-}

foreign import ccall "& wrapReleaseVideoWriter" releaseVideoWriter :: FinalizerPtr VideoWriter
-- NOTE: This use of foreignPtr is quite likely to cause trouble by retaining
--       videos longer than necessary.

type VideoStream c d = Stream IO (Image c d)

streamFromVideo cap   = dropS 1 $ streamFromVideo' (undefined) cap 
streamFromVideo' p cap = Value $ do
                         x <- getFrame cap
                         case x of
                            Just f -> return (p,(streamFromVideo' f cap))
                            Nothing -> return (p,Terminated)
                        

captureFromFile fn = withCString fn $ \cfn -> do
                      ptr <- cvCreateFileCapture cfn
                      fptr <- newForeignPtr releaseCapture ptr
                      return . Capture $ fptr

captureFromCam int = do
                      ptr <- cvCreateCameraCapture (fromIntegral int)
                      if  ptr==nullPtr 
                        then 
                          return Nothing
                        else do
                          fptr <- newForeignPtr releaseCapture ptr
                          return . Just . Capture $ fptr

dropFrame cap = withCapture cap $ \ccap -> cvGrabFrame ccap >> return ()

getFrame :: Capture -> IO (Maybe (Image RGB D32))
getFrame cap = withCapture cap $\ccap -> do
                p_frame <- cvQueryFrame ccap 
                if p_frame==nullPtr then return Nothing
                                    else creatingImage (ensure32F p_frame) >>= return . Just
                    -- NOTE: This works because Image module has generated wrappers for ensure32F

data CapProp = CAP_PROP_POS_MSEC
             | CAP_PROP_POS_FRAMES
             | CAP_PROP_POS_AVI_RATIO
             | CAP_PROP_FRAME_WIDTH
             | CAP_PROP_FRAME_HEIGHT
             | CAP_PROP_FPS
             | CAP_PROP_FOURCC
             | CAP_PROP_FRAME_COUNT
             | CAP_PROP_FORMAT
             | CAP_PROP_MODE
             | CAP_PROP_BRIGHTNESS
             | CAP_PROP_CONTRAST
             | CAP_PROP_SATURATION
             | CAP_PROP_HUE
             | CAP_PROP_GAIN
             | CAP_PROP_EXPOSURE
             | CAP_PROP_CONVERT_RGB
             | CAP_PROP_WHITE_BALANCE_BLUE_U
             | CAP_PROP_WHITE_BALANCE_RED_V
             | CAP_PROP_RECTIFICATION
             | CAP_PROP_MONOCROME
             
instance Enum CapProp where
  fromEnum CAP_PROP_POS_MSEC = 0
  fromEnum CAP_PROP_POS_FRAMES = 1
  fromEnum CAP_PROP_POS_AVI_RATIO = 2
  fromEnum CAP_PROP_FRAME_WIDTH = 3
  fromEnum CAP_PROP_FRAME_HEIGHT = 4
  fromEnum CAP_PROP_FPS = 5
  fromEnum CAP_PROP_FOURCC = 6
  fromEnum CAP_PROP_FRAME_COUNT = 7
  fromEnum CAP_PROP_FORMAT = 8
  fromEnum CAP_PROP_MODE = 9
  fromEnum CAP_PROP_BRIGHTNESS = 10
  fromEnum CAP_PROP_CONTRAST = 11
  fromEnum CAP_PROP_SATURATION = 12
  fromEnum CAP_PROP_HUE = 13
  fromEnum CAP_PROP_GAIN = 14
  fromEnum CAP_PROP_EXPOSURE = 15
  fromEnum CAP_PROP_CONVERT_RGB = 16
  fromEnum CAP_PROP_WHITE_BALANCE_BLUE_U = 17
  fromEnum CAP_PROP_WHITE_BALANCE_RED_V = 26
  fromEnum CAP_PROP_RECTIFICATION = 18
  fromEnum CAP_PROP_MONOCROME = 19

  toEnum 0 = CAP_PROP_POS_MSEC
  toEnum 1 = CAP_PROP_POS_FRAMES
  toEnum 2 = CAP_PROP_POS_AVI_RATIO
  toEnum 3 = CAP_PROP_FRAME_WIDTH
  toEnum 4 = CAP_PROP_FRAME_HEIGHT
  toEnum 5 = CAP_PROP_FPS
  toEnum 6 = CAP_PROP_FOURCC
  toEnum 7 = CAP_PROP_FRAME_COUNT
  toEnum 8 = CAP_PROP_FORMAT
  toEnum 9 = CAP_PROP_MODE
  toEnum 10 = CAP_PROP_BRIGHTNESS
  toEnum 11 = CAP_PROP_CONTRAST
  toEnum 12 = CAP_PROP_SATURATION
  toEnum 13 = CAP_PROP_HUE
  toEnum 14 = CAP_PROP_GAIN
  toEnum 15 = CAP_PROP_EXPOSURE
  toEnum 16 = CAP_PROP_CONVERT_RGB
  toEnum 17 = CAP_PROP_WHITE_BALANCE_BLUE_U
  toEnum 26 = CAP_PROP_WHITE_BALANCE_RED_V
  toEnum 18 = CAP_PROP_RECTIFICATION
  toEnum 19 = CAP_PROP_MONOCROME
  toEnum unmatched = error ("CapProp.toEnum: Cannot match " ++ show unmatched)

{-# LINE 91 "./CV/Video.chs" #-}

fromProp = fromIntegral . fromEnum

getCapProp cap prop = withCapture cap $\ccap ->
                         cvGetCaptureProperty 
                           ccap (fromProp prop) >>= return . realToFrac

getFrameRate cap = unsafePerformIO $
                      withCapture cap $\ccap ->
                         cvGetCaptureProperty 
                           ccap (fromProp CAP_PROP_FPS) >>= return . realToFrac

getFrameSize cap = unsafePerformIO $
                      withCapture cap $\ccap -> do
                         w <- cvGetCaptureProperty ccap (fromProp CAP_PROP_FRAME_WIDTH) 
                                >>= return . round
                         h <- cvGetCaptureProperty ccap (fromProp CAP_PROP_FRAME_HEIGHT)
                                >>= return . round
                         return (w,h)


setCapProp cap prop val = withCapture cap $\ccap ->
                         cvSetCaptureProperty 
                           ccap (fromProp prop) (realToFrac val)

numberOfFrames cap = unsafePerformIO $
                      withCapture cap $\ccap ->
                         cvGetCaptureProperty 
                           ccap (fromProp CAP_PROP_FRAME_COUNT)
                            >>= return . floor

frameNumber cap = unsafePerformIO $
                      withCapture cap $\ccap ->
                         cvGetCaptureProperty 
                          ccap (fromProp CAP_PROP_POS_FRAMES) >>= return . floor

-- Video Writing

data Codec = MPG4 deriving (Eq,Show)

createVideoWriter filename codec framerate frameSize = 
    withCString filename $ \cfilename -> do
        ptr <- wrapCreateVideoWriter cfilename fourcc 
                                              framerate w h 0
        if ptr == nullPtr then error "Could not create video writer" else return ()
        fptr <- newForeignPtr releaseVideoWriter ptr
        return . VideoWriter $ fptr
  where
    (fromIntegral -> w, fromIntegral -> h) = frameSize
    fourcc | codec == MPG4 = 0x4d504734 -- This is so wrong..

writeFrame :: VideoWriter -> Image RGB D32 -> IO ()
writeFrame writer img = withVideoWriter writer $\cwriter ->
                         withImage img    $ \cimg -> 
                          cvWriteFrame cwriter cimg >> return ()

foreign import ccall safe "CV/Video.chs.h cvCreateFileCapture"
  cvCreateFileCapture :: ((Ptr CChar) -> (IO (Ptr (Capture))))

foreign import ccall safe "CV/Video.chs.h cvCreateCameraCapture"
  cvCreateCameraCapture :: (CInt -> (IO (Ptr (Capture))))

foreign import ccall safe "CV/Video.chs.h cvGrabFrame"
  cvGrabFrame :: ((Ptr (Capture)) -> (IO CInt))

foreign import ccall safe "CV/Video.chs.h cvQueryFrame"
  cvQueryFrame :: ((Ptr (Capture)) -> (IO (Ptr (BareImage))))

foreign import ccall safe "CV/Video.chs.h cvGetCaptureProperty"
  cvGetCaptureProperty :: ((Ptr (Capture)) -> (CInt -> (IO CDouble)))

foreign import ccall safe "CV/Video.chs.h cvSetCaptureProperty"
  cvSetCaptureProperty :: ((Ptr (Capture)) -> (CInt -> (CDouble -> (IO CInt))))

foreign import ccall safe "CV/Video.chs.h wrapCreateVideoWriter"
  wrapCreateVideoWriter :: ((Ptr CChar) -> (CInt -> (CDouble -> (CInt -> (CInt -> (CInt -> (IO (Ptr (VideoWriter)))))))))

foreign import ccall safe "CV/Video.chs.h cvWriteFrame"
  cvWriteFrame :: ((Ptr (VideoWriter)) -> ((Ptr (BareImage)) -> (IO CInt)))