diff --git a/Examples/Example1.hs b/Examples/Example1.hs --- a/Examples/Example1.hs +++ b/Examples/Example1.hs @@ -57,7 +57,7 @@ print ("Trying camera", e) cam <- cameraFromID dc e-- c'dc1394_camera_new dc guid print ("Camera can do oneshots", oneShotCapable cam) - setISOSpeed cam ISO_400 + setISOSpeed cam ISO_800 setVideoMode cam Mode_640x480_RGB8 setFrameRate cam Rate_7_5 setupCamera cam 4 (defaultFlags) diff --git a/System/Camera/Firewire/Simple.hs b/System/Camera/Firewire/Simple.hs --- a/System/Camera/Firewire/Simple.hs +++ b/System/Camera/Firewire/Simple.hs @@ -1,4 +1,4 @@ -{-#LANGUAGE ScopedTypeVariables#-} +{-#LANGUAGE ScopedTypeVariables, TypeFamilies, DataKinds#-} module System.Camera.Firewire.Simple ( -- * Basic types Camera @@ -17,7 +17,8 @@ , cameraFromID , setFrameRate , setISOSpeed - , setVideoMode + , setOperationMode + , withVideoMode , setupCamera -- * Setting up the context, cameras and the transmission @@ -29,7 +30,36 @@ -- * Camera properties , oneShotCapable - + + -- * Controlling cameras + , resetCamera + , resetBus + , avtReset + , setPower + , setGain + , setBrightness + , setExposure + , setSharpness + , setHue + , setSaturation + , setGamma + , setShutter + , setGain + , setIris + , setFocus + , setTrigger + , setTriggerDelay +-- , setWhiteBalance +-- , setTemperature +-- , setWhiteShading + , setFeatureFrameRate + , setZoom + , setPan + , setTilt + , setOpticalFilter + , setCaptureSize + , setCaptureQuality + -- * Getting images , getFrame , flushBuffer @@ -37,6 +67,7 @@ , DCResult(..) , Framerate(..) , ISOSpeed(..) + , OperationMode(..) , VideoMode(..) @@ -49,6 +80,7 @@ import Control.Exception import Control.Monad import Data.Bits +import Data.Word import Foreign.C.Types import Foreign.Concurrent import Foreign.ForeignPtr hiding (newForeignPtr) @@ -57,6 +89,7 @@ import Foreign.Ptr import Foreign.Storable import System.IO.Unsafe +import Unsafe.Coerce getIds :: C'dc1394camera_list_t -> IO [C'dc1394camera_id_t] getIds camList = peekArray (fromIntegral $ c'dc1394camera_list_t'num camList) @@ -77,28 +110,89 @@ -- | Poll frames until the camera buffer is empty. Notice that you -- have to restart the transmission after this call -flushBuffer :: Camera -> IO () +flushBuffer :: Camera a -> IO () flushBuffer cam = alloca $ \(framePtrPtr :: Ptr (Ptr C'dc1394video_frame_t)) -> do withCameraPtr cam $ flushLoop framePtrPtr where flushLoop framePtrPtr cam = do c'dc1394_capture_dequeue cam c'DC1394_CAPTURE_POLICY_POLL framePtrPtr - print "Flush!" +-- print "Flush!" framePtr :: Ptr C'dc1394video_frame_t <- peek framePtrPtr - putStrLn $ show (framePtr,framePtrPtr) +-- putStrLn $ show (framePtr,framePtrPtr) when (framePtr /= nullPtr) $ c'dc1394_capture_enqueue cam framePtr >> flushLoop framePtrPtr cam +class GetFrame a where + type ResultImageOf a :: * + getFrame :: Camera a -> IO (Maybe (ResultImageOf a)) --- | Grab a frame from the camera. Currently does only 640x480 RGB D8 Images. -getFrame :: Camera -> IO (Maybe (Image RGB D8)) -getFrame camera' = alloca $ \(framePtr :: Ptr (Ptr C'dc1394video_frame_t)) -> + +-- | Grab a frame from the camera. +--getFrame :: Camera -> IO (Maybe (Image RGB D8)) +instance GetFrame Mode_640x480_RGB8 where + type ResultImageOf Mode_640x480_RGB8 = Image RGB D8 + getFrame camera' = getPrimalFrame camera' Mode_640x480_RGB8 convertToCVRGB + +instance GetFrame Mode_800x600_RGB8 where + type ResultImageOf Mode_800x600_RGB8 = Image RGB D8 + getFrame camera' = getPrimalFrame camera' Mode_800x600_RGB8 convertToCVRGB + +instance GetFrame Mode_1024x768_RGB8 where + type ResultImageOf Mode_1024x768_RGB8 = Image RGB D8 + getFrame camera' = getPrimalFrame camera' Mode_1024x768_RGB8 convertToCVRGB + +instance GetFrame Mode_1280x960_RGB8 where + type ResultImageOf Mode_1280x960_RGB8 = Image RGB D8 + getFrame camera' = getPrimalFrame camera' Mode_1280x960_RGB8 convertToCVRGB + +instance GetFrame Mode_640x480_MONO8 where + type ResultImageOf Mode_640x480_MONO8 = Image GrayScale D8 + getFrame camera' = getPrimalFrame camera' Mode_640x480_MONO8 convertToCVMONO8 + +instance GetFrame Mode_800x600_MONO8 where + type ResultImageOf Mode_800x600_MONO8 = Image GrayScale D8 + getFrame camera' = getPrimalFrame camera' Mode_800x600_MONO8 convertToCVMONO8 + +instance GetFrame Mode_1024x768_MONO8 where + type ResultImageOf Mode_1024x768_MONO8 = Image GrayScale D8 + getFrame camera' = getPrimalFrame camera' Mode_1024x768_MONO8 convertToCVMONO8 + +instance GetFrame Mode_1280x960_MONO8 where + type ResultImageOf Mode_1280x960_MONO8 = Image GrayScale D8 + getFrame camera' = getPrimalFrame camera' Mode_1280x960_MONO8 convertToCVMONO8 + +-- | Perform operations with a given video-mode. The idea is that each camera outside the +-- `withVideoMode` is represented with an UnsetMode with which you can't grab frames. +-- This is done regardless of the actual device mode. +class WithVideoMode a where + withVideoMode :: Camera UnsetMode -> (Camera a -> IO b) -> IO b + +instance WithVideoMode Mode_640x480_RGB8 where + withVideoMode cam op = withCameraPtr cam $ \camera -> + (checking $ c'dc1394_video_set_mode camera (toVideoMode Mode_640x480_RGB8)) + >> op (unsafeCoerce cam) + +instance WithVideoMode Mode_640x480_MONO8 where + withVideoMode cam op = withCameraPtr cam $ \camera -> + (checking $ c'dc1394_video_set_mode camera (toVideoMode Mode_640x480_MONO8)) + >> op (unsafeCoerce cam) + +instance WithVideoMode Mode_800x600_RGB8 where + withVideoMode cam op = withCameraPtr cam $ \camera -> + (checking $ c'dc1394_video_set_mode camera (toVideoMode Mode_800x600_RGB8)) + >> op (unsafeCoerce cam) + +instance WithVideoMode Mode_1280x960_RGB8 where + withVideoMode cam op = withCameraPtr cam $ \camera -> + (checking $ c'dc1394_video_set_mode camera (toVideoMode Mode_1280x960_RGB8)) + >> op (unsafeCoerce cam) + +getPrimalFrame camera' assumedMode conv = alloca $ \(framePtr :: Ptr (Ptr C'dc1394video_frame_t)) -> withCameraPtr camera' $ \camera -> do mode <- getMode camera - when (mode /= c'DC1394_VIDEO_MODE_640x480_RGB8) $ error "Unsupported mode. Use 640x480 RGB8 for now" - + when (mode /= fromVideoMode assumedMode) $ error "Mode sync error!" c'dc1394_capture_dequeue camera c'DC1394_CAPTURE_POLICY_WAIT framePtr frameP :: Ptr C'dc1394video_frame_t <- peek framePtr @@ -111,13 +205,42 @@ case corrupt of 0 -> do -- Yay! A frame! dataPtr <- c'dc1394video_frame_t'image <$> (peek framePtr >>= peek) - r <- unsafe8UC3FromPtr (640,480) dataPtr + r <- conv assumedMode dataPtr c'dc1394_capture_enqueue camera frameP return . Just $ r _ -> c'dc1394_capture_enqueue camera frameP >> return Nothing +convertToCVRGB mode dataPtr = case mode of + Mode_640x480_RGB8 -> unsafe8UC_BGRFromPtr (640,480) dataPtr + Mode_800x600_RGB8 -> unsafe8UC_BGRFromPtr (800,600) dataPtr + Mode_1024x768_RGB8 -> unsafe8UC_BGRFromPtr (1024,768) dataPtr + Mode_1280x960_RGB8 -> unsafe8UC_BGRFromPtr (1280,960) dataPtr + Mode_1600x1200_RGB8 -> unsafe8UC_BGRFromPtr (1600,1200) dataPtr +convertToCVMONO8 mode dataPtr = case mode of + Mode_640x480_MONO8 -> unsafe8UC_MONOFromPtr (640,480) dataPtr + Mode_800x600_MONO8 -> unsafe8UC_MONOFromPtr (800,600) dataPtr + Mode_1024x768_MONO8 -> unsafe8UC_MONOFromPtr (1024,768) dataPtr + Mode_1280x960_MONO8 -> unsafe8UC_MONOFromPtr (1280,960) dataPtr + Mode_1600x1200_MONO8 -> unsafe8UC_MONOFromPtr (1600,1200) dataPtr +convertToCVMONO16 mode dataPtr = case mode of + Mode_640x480_MONO16 -> error "Unsupported video mode" + Mode_800x600_MONO16 -> error "Unsupported video mode" + Mode_1024x768_MONO16 -> error "Unsupported video mode" + Mode_1280x960_MONO16 -> error "Unsupported video mode" + Mode_1600x1200_MONO16 -> error "Unsupported video mode" + +convertToCVYUV mode dataPtr = case mode of + Mode_160x120_YUV444 -> error "Unsupported video mode" + Mode_320x240_YUV422 -> error "Unsupported video mode" + Mode_640x480_YUV411 -> error "Unsupported video mode" + Mode_640x480_YUV422 -> error "Unsupported video mode" + Mode_800x600_YUV422 -> error "Unsupported video mode" + Mode_1024x768_YUV422 -> error "Unsupported video mode" + Mode_1280x960_YUV422 -> error "Unsupported video mode" + Mode_1600x1200_YUV422 -> error "Unsupported video mode" + getMode :: Ptr C'dc1394camera_t -> IO CInt getMode camera = alloca $ \(mode :: Ptr CInt) -> do c'dc1394_video_get_mode camera mode @@ -129,11 +252,12 @@ -- | Abstract type for cameras -data Camera = Camera (ForeignPtr C'dc1394camera_t) +data Camera (mode :: VideoMode) = Camera (ForeignPtr C'dc1394camera_t) +--type Camera = Camera' Mode_640x480_RGB8 -- | Create Camera from ID. Although the camera type is memory managed, the user is required -- to stop data transfer and reset appropriate settings. Finalizers are not quaranteed to run. -cameraFromID :: DC1394 -> CameraId -> IO Camera +cameraFromID :: DC1394 -> CameraId -> IO (Camera UnsetMode) cameraFromID dc e = do let guid = c'dc1394camera_id_t'guid e camera <- withDCPtr dc $ \c_dc -> c'dc1394_camera_new c_dc guid @@ -159,19 +283,19 @@ withDCPtr (DC1394 ptr) op = op ptr -- | Set the video transmission on -startVideoTransmission :: Camera -> IO () +startVideoTransmission :: Camera a -> IO () startVideoTransmission c = withCameraPtr c $ \camera -> checking $ c'dc1394_video_set_transmission camera c'DC1394_ON -- | Set the video transmission off. Call this when you are done with the camera -stopVideoTransmission :: Camera -> IO () +stopVideoTransmission :: Camera a -> IO () stopVideoTransmission c = withCameraPtr c $ \camera -> checking $ c'dc1394_video_set_transmission camera c'DC1394_OFF -- | Stop capturing. Call this when you are done with the camera. -stopCapture :: Camera -> IO () +stopCapture :: Camera a -> IO () stopCapture c = withCameraPtr c $ \camera -> checking $ c'dc1394_capture_stop camera -- | Does the camera have one-shot functionality? -oneShotCapable :: Camera -> Bool +oneShotCapable :: Camera a -> Bool oneShotCapable camera = unsafePerformIO $ withCamera camera (return . itob . c'dc1394camera_t'one_shot_capable) -- | Type for capture flags @@ -188,27 +312,102 @@ (&+) :: CaptureFlag -> CaptureFlag -> CaptureFlag CF a &+ CF b = CF (a .&. b) +-- | Set power. True = On, False = Off +setPower :: Camera a -> Bool -> IO () +setPower c state = withCameraPtr c $ \camera -> + checking $ c'dc1394_camera_set_power camera $ + case state of + True -> c'DC1394_ON + False -> c'DC1394_OFF + -- | Set ISO speed -setISOSpeed :: Camera -> ISOSpeed -> IO () +setISOSpeed :: Camera a -> ISOSpeed -> IO () setISOSpeed c iso = withCameraPtr c $ \camera -> checking $ c'dc1394_video_set_iso_speed camera (fromISO iso) --- | Set the video mode -setVideoMode :: Camera -> VideoMode -> IO () +-- | Set operation mode +data OperationMode = Legacy | B deriving (Eq,Ord,Show) + +setOperationMode :: Camera a -> OperationMode -> IO () +setOperationMode c mode = withCameraPtr c $ \camera -> + checking $ c'dc1394_video_set_operation_mode camera $ + case mode of + Legacy -> c'DC1394_OPERATION_MODE_LEGACY + B -> c'DC1394_OPERATION_MODE_1394B + +getOperationMode :: Camera a -> IO OperationMode +getOperationMode c = withCameraPtr c $ \camera -> + alloca $ \modeOut -> do + checking $ c'dc1394_video_get_operation_mode camera modeOut + r <- peek modeOut + if r == c'DC1394_OPERATION_MODE_LEGACY + then return Legacy + else return B -- TODO: Make this more secure by adding 'other' case + +-- | Reset the camera +resetCamera :: Camera a -> IO () +resetCamera c = withCameraPtr c $ \camera -> + checking $ c'dc1394_camera_reset camera +-- | Reset the bus +resetBus :: Camera a -> IO () +resetBus c = withCameraPtr c $ \camera -> + checking $ c'dc1394_reset_bus camera + +-- | AVT Reset +avtReset :: Camera a -> IO () +avtReset c = withCameraPtr c $ \camera -> + checking $ c'dc1394_avt_reset camera + +-- | Set the video mode, type-UNSAFE at current point.. +setVideoMode :: Camera a -> VideoMode -> IO () setVideoMode c mode = withCameraPtr c $ \camera -> checking $ c'dc1394_video_set_mode camera (toVideoMode mode) -- | Set the frame rate -setFrameRate :: Camera -> Framerate -> IO () +setFrameRate :: Camera a -> Framerate -> IO () setFrameRate c rate = withCameraPtr c $ \camera -> checking $ c'dc1394_video_set_framerate camera (toFramerate rate) -- | Setup the camera for capturing -setupCamera :: Camera -> Int -> CaptureFlag -> IO () +setupCamera :: Camera a -> Int -> CaptureFlag -> IO () setupCamera c dmaBuffers cf = withCameraPtr c $ \camera -> checking $ c'dc1394_capture_setup camera (fromIntegral dmaBuffers) (fromCF cf) +-- | Set camera shutter speed + +setFeature :: CUInt -> Camera a -> Word32 -> IO () +setFeature f c speed = withCameraPtr c $ \camera -> + checking $ c'dc1394_feature_set_value + camera + f + (fromIntegral speed) + +setBrightness = setFeature c'DC1394_FEATURE_BRIGHTNESS +setExposure = setFeature c'DC1394_FEATURE_EXPOSURE +setSharpness = setFeature c'DC1394_FEATURE_SHARPNESS +setHue = setFeature c'DC1394_FEATURE_HUE +setSaturation = setFeature c'DC1394_FEATURE_SATURATION +setGamma = setFeature c'DC1394_FEATURE_GAMMA +setShutter = setFeature c'DC1394_FEATURE_SHUTTER +setGain = setFeature c'DC1394_FEATURE_GAIN +setIris = setFeature c'DC1394_FEATURE_IRIS +setFocus = setFeature c'DC1394_FEATURE_FOCUS +setTrigger = setFeature c'DC1394_FEATURE_TRIGGER +setTriggerDelay = setFeature c'DC1394_FEATURE_TRIGGER_DELAY +setFeatureFrameRate = setFeature c'DC1394_FEATURE_FRAME_RATE +setZoom = setFeature c'DC1394_FEATURE_ZOOM +setPan = setFeature c'DC1394_FEATURE_PAN +setTilt = setFeature c'DC1394_FEATURE_TILT +setOpticalFilter = setFeature c'DC1394_FEATURE_OPTICAL_FILTER +setCaptureSize = setFeature c'DC1394_FEATURE_CAPTURE_SIZE +setCaptureQuality = setFeature c'DC1394_FEATURE_CAPTURE_QUALITY +-- These are multiple valued and cannot be set as features +-- setWhiteBalance = setFeature c'DC1394_FEATURE_WHITE_BALANCE +-- setWhiteShading = setFeature c'DC1394_FEATURE_WHITE_SHADING +-- setTemperature = setFeature c'DC1394_FEATURE_TEMPERATURE + + -- | Execute a libdc1394 function and check for the error code. Currently raises the error as -- UserError, but in future might provide a more reasonable error hierarchy. checking :: IO CInt -> IO () @@ -402,6 +601,7 @@ | Mode_FORMAT7_5 | Mode_FORMAT7_6 | Mode_FORMAT7_7 + | UnsetMode deriving (Show,Eq) fromVideoMode Mode_160x120_YUV444 = c'DC1394_VIDEO_MODE_160x120_YUV444 diff --git a/simple-firewire.cabal b/simple-firewire.cabal --- a/simple-firewire.cabal +++ b/simple-firewire.cabal @@ -1,5 +1,5 @@ Name: simple-firewire -Version: 0.1.3.3 +Version: 0.1.3.4 Synopsis: Simplified interface for firewire cameras Description: A simplified interface for firewire cameras based on libdc1394 . @@ -26,7 +26,7 @@ Build-depends: base > 4 && < 5, bindings-dc1394 >= 0.2 && < 1, - CV >= 0.3.1.2 && < 0.4 + CV >= 0.3.1.3 && < 0.4.5 -- Other-modules: -- Build-tools: