diff --git a/Data/Camera.hs b/Data/Camera.hs new file mode 100644 --- /dev/null +++ b/Data/Camera.hs @@ -0,0 +1,13 @@ +-- | +-- Module : Video.Camera +-- Maintainer : Yakov Zaytsev +-- Stability : experimental +-- + +module Data.Camera ( + Camera + ) where + +import Data.Image + +type Camera a = IO (Image a) diff --git a/Data/Geometry.hs b/Data/Geometry.hs new file mode 100644 --- /dev/null +++ b/Data/Geometry.hs @@ -0,0 +1,42 @@ +-- | +-- +-- + +module Data.Geometry where + +type Coord = Int + +type Point = (Coord, Coord) + +type Size = (Int, Int) +-- data Size = Size Int Int + +type Origin = Point + +-- | +-- +-- Origin +-- *--- +-- | +-- | Size +-- +-- +data Region = Rectangle Origin Size deriving Show + +-- downSample :: Size -> Int -> Size +-- downSample (w, h) factor = (w `div` factor, h `div` factor) + +translate :: Point -> Point -> Point +translate (ox, oy) (x, y) = (ox + x, oy + y) + +-- | +-- Makes rectangle region. +-- +-- Second argument is center of the rectangle +withCenter :: Size -> Point -> Region +size@(w, h) `withCenter` o = Rectangle o' size + where + o' = translate o (-w `div` 2, -h `div` 2) + +points :: Region -> [Point] +points (Rectangle (ox, oy) (w, h)) = [(x, y) | y <- [oy .. (oy + h)], x <- [ox .. (ox + w)]] diff --git a/Data/Image.hs b/Data/Image.hs new file mode 100644 --- /dev/null +++ b/Data/Image.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ExistentialQuantification #-} + +-- | +-- Module : Data.Image +-- Maintainer : Yakov Zaytsev +-- Stability : experimental +-- +-- Functional image +-- +-- To-Do: +-- +-- * ??? +-- > type ImageT = Image a -> Image b +-- + +module Data.Image ( + Image + , ColorC + , GrayImage + , RGB(..) + + , (.|) + , (*|) + + , (.-) + , (.^) + + , crop + + , threshold + + -- * Geometry + , intervalAt + + -- * Misc + , square + , inW + ) where + +import Foreign.Ptr +import Foreign.Storable +import qualified Graphics.UI.GLUT as G (Size(..)) +import Data.Word + +import Data.Geometry + +-- | +-- Image with pixels represented as values of type a. +-- +-- To-Do +-- +-- * +-- > instance Num Image a where +-- Or make individual operators (-), (+) etc. +-- +-- See also 'RGB'. +-- +type Image a = Point -> a +-- XXX +-- data Image a = Image (Point -> a) +-- | Image a `Over` Image + + +-- | Color index. +type ColorC = Word32 + +type GrayImage = Image ColorC + +class RGB c where + toRGB :: c -> (ColorC, ColorC, ColorC) + +-- class Yuv c where +-- getY :: c -> ColorC + +intervalAt :: Int -> Int -> [Int] +intervalAt y windowH = [y - windowH `div` 2 .. y + windowH `div` 2] + + +type Window = Size + +inW :: Point -> Window -> Bool +inW (x, y) (w, h) = x >= 0 && x < w && y >= 0 && y < h + +square x = x * x + +-- | +(*|) :: (Storable a) => Image a -> (Ptr a, G.Size) -> IO () +f *| (ptr, G.Size w' h') = do + sequence_ $ map pokeP ps + where + w = fromIntegral w' -- View pattern + h = fromIntegral h' + ps = points $ Rectangle (0, 0) (w - 1, h - 1) -- [(x, y) | y <- [0 .. h - 1], x <- [0 .. w - 1]] + pokeP p@(x, y) = let idx = (y * w + x) in pokeElemOff ptr idx $ f p + +-- -- | +-- -- Example: +-- -- +-- -- > let g = toGray frame +-- -- > withArray (g .| frameSize) -> \gg -> displayPixels frameSize (PixelData Luminance UnsignedByte gg) +-- -- +-- (*|) :: Image a -> Size -> [a] +-- f *| (w, h) = f .| ps +-- where +-- ps = [(x, y) | y <- [0 .. h - 1], x <- [0 .. w - 1]] + + +-- | +-- ??? +(.|) :: Image a -> [Point] -> [a] +f .| ps = map f ps + + +threshold :: (Ord a, Num a) => a -> Image a -> Image a +threshold t f (x, y) + | ff < t = 0 + | otherwise = ff + where + ff = f (x, y) +-- threshold :: ColorC -> GrayImage -> GrayImage +-- threshold t f (x, y) +-- | ff < t = 0 +-- | otherwise = ff +-- where +-- ff = f (x, y) + +crop' :: a -> Image a -> Region -> Image a +crop' ff f (Rectangle orig window) + = g + where + g p + | p `inW` window = f $ translate orig p + | otherwise = ff + +crop :: forall a . (Num a) => Image a -> Region -> Image a +crop = crop' 0 + +(.-) :: (Num a) => Image a -> Image a -> Image a +f .- g = h + where + h p = f p - g p + +(.^) :: (Num a) => Image a -> Int -> Image a +f .^ 2 = g + where + g p = (f p) * (f p) -- ??? diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2009 Yakov Zaytsev +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Mac.hs b/Mac.hs new file mode 100644 --- /dev/null +++ b/Mac.hs @@ -0,0 +1,206 @@ +-- | +-- Module : Mac +-- Maintainer : Yakov Z <> +-- Stability : experimental +-- +-- Functions to capture live video on a Mac OS X +-- +-- Example: +-- +-- > initCursor +-- > enterMovies +-- > camera <- with Rect { top = 0, left = 0, bottom = 480, right = 640 } $ \r -> newSGChannel r +-- + +module Mac ( + newSGChannel + , Rect(..) + , initCursor + , enterMovies + ) where + +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils +import Foreign.Storable +import Foreign.Ptr +import Foreign.StablePtr +-- XXX +import Foreign.C.Types + +import Data.Word +import Data.Bits +import Data.Int +import Data.IORef +import System.IO.Unsafe +import Control.Concurrent + + +import Mac.Carbon +import Mac.QuickDraw +import Mac.QuickTime + +import Data.Camera +import Data.Image +import Data.Geometry + + +data MungData = MungData { gWorld :: GWorld, + boundsRect :: Ptr Rect, + decomSeq' :: Ptr ImageSequence, + hasBeenDecomp :: IORef Bool + } + +newtype GWorldC = GWorldC Word32 + +instance RGB GWorldC where + toRGB (GWorldC color) = (r, g, b) + where + r = (color .&. 0x00FF0000) `shiftR` 16 + g = (color .&. 0x0000FF00) `shiftR` 8 + b = (color .&. 0x000000FF) `shiftR` 0 + +-- | Offscreen graphics world +newtype GWorld = GWorld { pGWorld :: GWorldPtr } + +-- | Creates an offscreen graphics world. +-- +-- The first argument specifies boundary rectangle and port rectangle for the offscreen pixel map. +-- +newGWorld :: Ptr Rect -> IO GWorld +newGWorld bounds = do + pGW' <- malloc + qTNewGWorld pGW' k32ARGBPixelFormat bounds nullPtr nullPtr 0 "qTNewGWorld failed" + pGWorld <- peek pGW' + pixMap' <- getPortPixMap pGWorld + b <- lockPixels pixMap' + if b /= true + then error "lockPixels failed" + else do return $ GWorld { pGWorld = pGWorld } + +fromGWorld :: GWorld -> Image GWorldC +fromGWorld gWorld = gWorldXY baseA rowBytes + where + baseA = baseAddr pixMap -- ??? + pixMap = unsafePerformIO $ getPixMap gWorld + rowBytes = unsafePerformIO $ do + pM'' <- getPortPixMap (pGWorld gWorld) + getPixRowBytes pM'' + +gWorldXY :: Ptr () -> CInt -> Point -> GWorldC +gWorldXY baseA rowBytes (x, y) = GWorldC $ unsafePerformIO $ peek $ rowAddr `plusPtr` ((fromIntegral x) * 4) + where + rowAddr = baseA `plusPtr` ((fromIntegral y) * (fromIntegral rowBytes)) + +getPixMap :: GWorld -> IO PixMap +getPixMap gWorld = do + pM'' <- getPortPixMap (pGWorld gWorld) + pM' <- peek pM'' + peek pM' + + +initSequence c gpData = do + h <- newHandle 0 + sGGetChannelSampleDescription c h "sGGetChannelSampleDescription failed" + + imageDesc' <- peek (castPtr h) + imageDesc <- peek imageDesc' + + with (Rect { top = 0, left = 0, bottom = (height imageDesc), right = (width imageDesc) }) $ \sourceRect -> + alloca $ \scaleMatrix -> do + rectMatrix scaleMatrix sourceRect (boundsRect gpData) + + err <- decompressSequenceBegin + (decomSeq' gpData) + (castPtr h) + (pGWorld (gWorld gpData)) + nullPtr + nullPtr + scaleMatrix + srcCopy + nullPtr + 0 + codecNormalQuality + bestSpeedCodec + if err /= 0 + then error "decompressSequenceBegin failed" + else disposeHandle h >> return 0 + + +mySGDataProc :: SGDataProc +-- mySGDataProc c p len offset chRefCon time writeType refCon +mySGDataProc c p len _ _ _ _ refCon + = do gpData <- deRefStablePtr $ castPtrToStablePtr refCon + + decomSeq <- peek $ decomSeq' gpData + if decomSeq == 0 + then initSequence c gpData + + -- decompress a frame into the GWorld + else do ignore <- malloc + err <- decompressSequenceFrameS decomSeq p len 0 ignore nullPtr + if err /= 0 + then error "decompressSequenceFrameS failed" + + -- IMAGE IS NOW IN THE GWORLD + + else writeIORef (hasBeenDecomp gpData) True >> return 0 + + +grabOne :: SeqGrabComponent -> IORef Bool -> Image GWorldC -> Camera GWorldC +grabOne seqGrab hBDRef image = do + writeIORef hBDRef False + sGIdle seqGrab "sGIdle failed" + hBD <- readIORef hBDRef + if hBD then return image else do { threadDelay 40 ; grabOne seqGrab hBDRef image } + + +-- | Initialize sequence grabber, create a new video channel, and return 'Camera' value +-- +-- The first argument specifies a channel's display boundary rectangle. +-- +-- XXX - It creates a new Carbon window to get a port, even if sequence grabber is not drawing to it.. +-- +newSGChannel :: Ptr Rect -> IO (Camera GWorldC) +newSGChannel theRect = do + pWindow' <- malloc + createNewWindow kDocumentWindowClass kWindowNoAttributes theRect pWindow' + pWindow <- peek pWindow' + showWindow pWindow + + seqGrab <- openDefaultComponent seqGrabComponentType 0 + if seqGrab == nullPtr + then error "openDefaultComponent failed" + else do + sGInitialize seqGrab "sGInitialize failed" + sGSetDataRef seqGrab nullPtr 0 seqGrabDontMakeMovie "sGSetDataRef failed" + gp <- getWindowPort pWindow + gd <- getMainDevice + sGSetGWorld seqGrab gp gd "sGSetGWorld failed" + sgchanVideo' <- malloc + + sGNewChannel seqGrab videoMediaType sgchanVideo' "sGNewChannel failed" + sgchanVideo <- peek sgchanVideo' + sGSetChannelBounds sgchanVideo theRect "sGSetChannelBounds failed" + sGSetChannelUsage sgchanVideo seqGrabRecord "sGSetChannelUsage failed" + + gWorld <- newGWorld theRect + userRoutine <- mkSGDataProc mySGDataProc + proc <- newSGDataUPP userRoutine + + decomSeq <- malloc + + poke decomSeq 0 + + hBDRef <- newIORef False + let gpD' = MungData { gWorld = gWorld, + boundsRect = theRect, + decomSeq' = decomSeq, + hasBeenDecomp = hBDRef } + + gpD <- newStablePtr gpD' + + sGSetDataProc seqGrab proc (castStablePtrToPtr gpD) + sGStartRecord seqGrab "sGStartRecord failed" + + return $ grabOne seqGrab hBDRef $ fromGWorld gWorld + diff --git a/Mac/Carbon.hsc b/Mac/Carbon.hsc new file mode 100644 --- /dev/null +++ b/Mac/Carbon.hsc @@ -0,0 +1,139 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module : Mac.Carbon +-- Maintainer : Yakov Z <> +-- Stability : experimental +-- + +module Mac.Carbon ( + OSType, + + -- * Error Handler + OSErr, + OSStatus, + + -- * Window Manager + WindowClass, + WindowAttributes, + Rect(..), + WindowRef, + CGrafPtr, + + kDocumentWindowClass, + kWindowNoAttributes, + + -- ** Creating, Storing, and Closing Windows + createNewWindow, + + -- ** Displaying Windows + showWindow, + + -- ** Getting and Setting Window Structure Fields + getWindowPort, + + -- * Component Manager + + -- ** Opening and Closing Components + openDefaultComponent, + + -- * Memory Manager + Handle, + Size, + + -- ** Allocating and Releasing Relocatable Blocks of Memory + disposeHandle, + newHandle, + + + TimeValue, + + Boolean, + true, + false, + + button + ) where + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.Storable + +#include + +-- | A numeric code used in Carbon to idndicate the return status of a function. +-- +-- Declared in IOMacOSTypes.h +type OSErr = CShort + +-- | A numeric code used in Carbon to indicate the return status of a function. +-- +-- Declared in OSTypes.h +type OSStatus = CInt + +type WindowClass = CInt +kDocumentWindowClass :: WindowClass +kDocumentWindowClass = (#const kDocumentWindowClass) + +type WindowAttributes = CInt +kWindowNoAttributes :: WindowAttributes +kWindowNoAttributes = (#const kWindowNoAttributes) + +data Rect = Rect { top :: CShort, + left :: CShort, + bottom :: CShort, + right :: CShort } +instance Storable Rect where + sizeOf _ = #const sizeof(Rect) + alignment _ = alignment (undefined :: CInt) -- ??? + peek _ = error "Storable.peek(MacTypes.Rect) not implemented" + poke p (Rect top' left' bottom' right') + = do (#poke Rect, top) p top' + (#poke Rect, left) p left' + (#poke Rect, bottom) p bottom' + (#poke Rect, right) p right' + +type CGrafPtr = Ptr () + +type WindowRef = Ptr () + +type OSType = CLong + +-- | +type Handle = Ptr () + +type Size = CLong + +type Boolean = CInt + +type TimeValue = CInt + + +true, false :: Boolean +true = #const true +false = #const false + + +-- | Creates a window from parameter data. +foreign import ccall unsafe "CreateNewWindow" createNewWindow :: WindowClass -> WindowAttributes -> {- const -} Ptr (Rect) -> Ptr (WindowRef) -> IO OSStatus + +-- | Make an invisible window visible. +foreign import ccall unsafe "ShowWindow" showWindow :: WindowRef -> IO () + +foreign import ccall unsafe "GetWindowPort" getWindowPort :: WindowRef -> IO CGrafPtr + + +-- | Opens a connection to a registered component of the component type and subtype specified by your application. +foreign import ccall unsafe "OpenDefaultComponent" openDefaultComponent :: OSType -> OSType -> IO (Ptr a) + + +-- | Allocates a new relocatable memory block of a specified size in the current heap zone. +foreign import ccall unsafe "NewHandle" newHandle :: Size -> IO Handle + +-- | Releases memory occupied by a relocatable block. +foreign import ccall unsafe "DisposeHandle" disposeHandle :: Handle -> IO () + + +-- | +foreign import ccall unsafe "Button" button :: IO Boolean + diff --git a/Mac/QuickDraw.hsc b/Mac/QuickDraw.hsc new file mode 100644 --- /dev/null +++ b/Mac/QuickDraw.hsc @@ -0,0 +1,81 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module : Mac.QuickDraw +-- Maintainer : Yakov Z <> +-- Stability : experimental +-- + +module Mac.QuickDraw ( + -- * QuickDraw + GDHandle, + PixMap(..), + +--TO-DO hide + PixMapHandle, + + -- ** Hiding and Showing Cursors + initCursor, + + -- ** Getting the Available Graphics Devices + getMainDevice, + + -- ** Managing and Offscreen Graphics World's Pixel Image + getPixBaseAddr, + lockPixels, + + -- ** Miscellaneous + getPortPixMap, + getPixRowBytes + ) where + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.Storable + +import Mac.Carbon + +#include + +type GDHandle = Ptr () + +-- | Contains information about the dimensions and contents of a pixel image, as well as +-- its storage format, depth, resolution, and color usage. +-- +-- For an onscreen pixel image, 'baseAddr' is a pointer to the first byte of the image. For optimal performance, +-- this should be multiple of 4. +-- +-- The 'baseAddr' of the 'PixMap' for an /offscreen/ graphics world contains a handle instead of a pointer. +-- +-- Your application should never directly access the 'baseAddr' for an /offscreen/ graphics world. +-- +-- +-- +data PixMap = PixMap { baseAddr :: Ptr (), + rowBytes :: CShort + } +instance Storable PixMap where + sizeOf _ = #const sizeof(PixMap) + alignment _ = alignment (undefined :: CInt) -- ??? + peek p = do + baseAddr' <- (#peek PixMap, baseAddr) p + rowBytes' <- (#peek PixMap, rowBytes) p + return PixMap { baseAddr = baseAddr', rowBytes = rowBytes' } + +type PixMapPtr = Ptr PixMap +type PixMapHandle = Ptr PixMapPtr + +-- | Sets the cursor to the standard arrow and makes the cursor visible. +foreign import ccall unsafe "InitCursor" initCursor :: IO () + +-- | Obtains a handle to the GDevice structure for the main screen. +-- +-- Deprecated in Mac OS X v10.4 +foreign import ccall unsafe "GetMainDevice" getMainDevice :: IO GDHandle + +foreign import ccall unsafe "GetPixBaseAddr" getPixBaseAddr :: PixMapHandle -> IO (Ptr ()) +foreign import ccall unsafe "LockPixels" lockPixels :: PixMapHandle -> IO Boolean + +foreign import ccall unsafe "GetPortPixMap" getPortPixMap :: CGrafPtr -> IO PixMapHandle +foreign import ccall unsafe "GetPixRowBytes" getPixRowBytes :: PixMapHandle -> IO CInt + diff --git a/Mac/QuickTime.hsc b/Mac/QuickTime.hsc new file mode 100644 --- /dev/null +++ b/Mac/QuickTime.hsc @@ -0,0 +1,255 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module : Mac.QuickTime +-- Maintainer : Yakov Z <> +-- Stability : experimental +-- + +module Mac.QuickTime ( + ComponentResult, + + ImageDescriptionPtr, + height, + width, + + noErr, + srcCopy, + codecNormalQuality, + bestSpeedCodec, + videoMediaType, + seqGrabRecord, + k32ARGBPixelFormat, +-- k24RGBPixelFormat, + + -- * Sequence Grabber + SeqGrabComponent, + + SGDataProc, + SGDataProcPtr, + SGDataUPP, + + -- ** Configuring Sequence Grabber Components + seqGrabComponentType, + seqGrabDontMakeMovie, + + sGInitialize, + sGNewChannel, + mkSGDataProc, + newSGDataUPP, + sGSetDataProc, + sGSetDataRef, + sGSetGWorld, + + -- ** Controlling Sequence Grabber Components + sGIdle, + sGStartRecord, + sGStop, + + -- ** Working with Channel Characteristics + sGSetChannelBounds, + sGGetChannelSampleDescription, + sGSetChannelUsage, + + -- * Compression and Decompression + MatrixRecord, + GWorldPtr, + ImageSequence, + + -- ** Managing Matricies + rectMatrix, + + -- ** Working with Sequences + decompressSequenceBegin, + decompressSequenceFrameS, + + -- ** Supporing Functions + qTNewGWorld, + + -- * Movie Manager + -- ** Initializing the Movie Toolbox + enterMovies, + + (), + ) where + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.Storable + +import Mac.Carbon +import Mac.QuickDraw + +#include + +data MatrixRecord = MatrixRecord +instance Storable MatrixRecord where + sizeOf _ = #const sizeof(MatrixRecord) + alignment _ = alignment (undefined :: CInt) -- ??? + +type ComponentResult = CLong + +type SeqGrabComponent = Ptr () + +type SGChannel = Ptr () + +type GWorldPtr = CGrafPtr + +-- | +-- +-- The sixth argument is the starting time of the data, in the channels time scale. +-- +type SGDataProc = SGChannel -> Ptr () -> CLong -> Ptr CLong -> CLong -> TimeValue -> CShort -> Ptr () -> IO OSErr +{- + MungGrabDataProc - the sequence grabber calls the data function whenever + any of the grabbers channels write digitized data to the destination movie file. + + NOTE: We really mean any, if you have an audio and video channel then the DataProc will + be called for either channel whenever data has been captured. Be sure to check which + channel is being passed in. In this example we never create an audio channel so we know + we're always dealing with video. + + This data function does two things, it first decompresses captured video + data into an offscreen GWorld, draws some status information onto the frame then + transfers the frame to an onscreen window. + + For more information refer to Inside Macintosh: QuickTime Components, page 5-120 + c - the channel component that is writing the digitized data. + p - a pointer to the digitized data. + len - the number of bytes of digitized data. + offset - a pointer to a field that may specify where you are to write the digitized data, + and that is to receive a value indicating where you wrote the data. + chRefCon - per channel reference constant specified using SGSetChannelRefCon. + time - the starting time of the data, in the channels time scale. + writeType - the type of write operation being performed. + seqGrabWriteAppend - Append new data. + seqGrabWriteReserve - Do not write data. Instead, reserve space for the amount of data + specified in the len parameter. + seqGrabWriteFill - Write data into the location specified by offset. Used to fill the space + previously reserved with seqGrabWriteReserve. The Sequence Grabber may + call the DataProc several times to fill a single reserved location. + refCon - the reference constant you specified when you assigned your data function to the sequence grabber. +-} + +type SGDataProcPtr = FunPtr SGDataProc + +type SGDataUPP = SGDataProcPtr + +type GWorldFlags = CULong + +type ImageSequence = CLong + +type ImageDescriptionPtr = Ptr ImageDescription + +type ImageDescriptionHandle = Ptr ImageDescriptionPtr + +data ImageDescription = ImageDescription { width :: CShort, + height :: CShort + } +instance Storable ImageDescription where + sizeOf _ = #const sizeof(ImageDescription) + alignment _ = alignment (undefined :: CInt) -- ??? + peek p = do + width' <- (#peek ImageDescription, width) p + height' <- (#peek ImageDescription, height) p + return ImageDescription { width = width', height = height' } + poke p (ImageDescription width' height') = do (#poke ImageDescription, width) p width' + (#poke ImageDescription, height) p height' + +type RgnHandle = Ptr () + +type CodecFlags = CUShort + +type CodecQ = CUShort + +type Component = CULong + +data RGBColor = RGBColor { red :: CUShort, green :: CUShort, blue :: CUShort } +instance Storable RGBColor where + sizeOf _ = #const sizeof(RGBColor) + alignment _ = alignment (undefined :: CInt) -- ??? + peek p = do + red' <- (#peek RGBColor, red) p + green' <- (#peek RGBColor, green) p + blue' <- (#peek RGBColor, blue) p + return RGBColor { red = red', green = green', blue = blue' } + + +() :: IO ComponentResult -> String -> IO () +act msg = act >>= \err -> if err /= noErr then error (msg ++ ": " ++ (show err)) else return () + +noErr :: ComponentResult +noErr = #const noErr + +seqGrabComponentType :: OSType +seqGrabComponentType = #const SeqGrabComponentType + +seqGrabDontMakeMovie :: CLong +seqGrabDontMakeMovie = #const seqGrabDontMakeMovie + +videoMediaType :: OSType +videoMediaType = #const VideoMediaType + +seqGrabRecord :: CLong +seqGrabRecord = #const seqGrabRecord + +k32ARGBPixelFormat, k24RGBPixelFormat :: OSType +k32ARGBPixelFormat = #const k32ARGBPixelFormat +k24RGBPixelFormat = #const k24RGBPixelFormat + +srcCopy :: CShort +srcCopy = #const srcCopy + +codecNormalQuality :: CodecQ +codecNormalQuality = #const codecNormalQuality + +bestSpeedCodec :: Component +bestSpeedCodec = #const bestSpeedCodec + + +foreign import ccall unsafe "SGStop" sGStop :: SeqGrabComponent -> IO ComponentResult +foreign import ccall unsafe "SGInitialize" sGInitialize :: SeqGrabComponent -> IO ComponentResult +foreign import ccall unsafe "SGSetDataRef" sGSetDataRef :: SeqGrabComponent -> Handle -> OSType -> CLong -> IO ComponentResult +foreign import ccall unsafe "SGSetGWorld" sGSetGWorld :: SeqGrabComponent -> CGrafPtr -> GDHandle -> IO ComponentResult +foreign import ccall unsafe "SGNewChannel" sGNewChannel :: SeqGrabComponent -> OSType -> Ptr SGChannel -> IO ComponentResult +foreign import ccall unsafe "SGSetChannelBounds" sGSetChannelBounds :: SGChannel -> Ptr Rect -> IO ComponentResult +foreign import ccall unsafe "SGSetChannelUsage" sGSetChannelUsage :: SGChannel -> CLong -> IO ComponentResult +foreign import ccall unsafe "SGStartRecord" sGStartRecord :: SeqGrabComponent -> IO ComponentResult + +-- | Provides processing time for sequence grabber components. +-- +-- After starting a preview operation, the application calls this function /as often as possible/. +-- +-- If your component returns a non-'noErr' result during a record operation, the application should call 'sGStop' so that the sequence grabber component can store the data it has collected. +-- +foreign import ccall safe "SGIdle" sGIdle :: SeqGrabComponent -> IO ComponentResult + +foreign import ccall "wrapper" mkSGDataProc :: SGDataProc -> IO SGDataProcPtr +foreign import ccall unsafe "NewSGDataUPP" newSGDataUPP :: SGDataProcPtr -> IO SGDataUPP +foreign import ccall unsafe "SGSetDataProc" sGSetDataProc :: SeqGrabComponent -> SGDataUPP -> Ptr () -> IO ComponentResult +foreign import ccall unsafe "SGGetChannelSampleDescription" sGGetChannelSampleDescription :: SGChannel -> Handle -> IO ComponentResult + + +-- | Creates a matrix that performs the translate and scale operation described by the relationship between two rectangles. +foreign import ccall unsafe "RectMatrix" rectMatrix :: Ptr MatrixRecord -> Ptr Rect -> Ptr Rect -> IO () + + +foreign import ccall unsafe "DecompressSequenceBegin" decompressSequenceBegin :: Ptr ImageSequence -> ImageDescriptionHandle -> CGrafPtr -> GDHandle -> Ptr Rect -> Ptr MatrixRecord -> CShort -> RgnHandle -> CodecFlags -> CodecQ -> Component -> IO OSErr + +foreign import ccall unsafe "DecompressSequenceFrameS" decompressSequenceFrameS :: ImageSequence -> Ptr () -> CLong -> CodecFlags -> Ptr CodecFlags -> Ptr () -> IO OSErr + + +-- | Creates an offscreen graphics world that may have non-Macintosh pixel format. +-- +-- Related Sample Code +-- +-- * VideoProcessing +foreign import ccall unsafe "QTNewGWorld" qTNewGWorld :: Ptr GWorldPtr -> OSType -> Ptr Rect -> Ptr () -> Ptr () -> GWorldFlags -> IO ComponentResult + + +-- | Initializes the Movie Toolbox and creates a private storage area for your application. +-- +-- Be sure to check the value returned by this function before using any other facilities of the Movie Toolbox. +foreign import ccall unsafe "EnterMovies" enterMovies :: IO OSErr + + diff --git a/Minimung.hs b/Minimung.hs new file mode 100644 --- /dev/null +++ b/Minimung.hs @@ -0,0 +1,66 @@ +-- | +-- Maintainer : Yakov Zaytsev +-- Stability : experimental +-- +-- This example shows how to run the Sequence Grabber in record mode +-- and how to get and modify the captured data. +-- + +module Main where + +import System.Exit(exitWith, ExitCode(ExitSuccess)) +import Graphics.UI.GLUT +import Foreign.Marshal.Array +import Foreign.Marshal.Alloc +import Foreign.Marshal.Utils +import Data.Bits + +import Mac +import Data.Image +import Data.Camera + +toGray :: (RGB a) => Image a -> Image (Index1 GLubyte) +toGray f = \(x, y) -> toY $ f (x, y) + +toY :: (RGB a, Num b) => a -> Index1 b +toY color = let (r, g, b) = toRGB color + in Index1 $ fromIntegral $ (r + (r `shiftL` 2) + g + (g `shiftL` 3) + (b + b)) `shiftR` 4 + +timer :: (RGB a) => Camera a -> TimerCallback +timer camera = do + frame <- camera + let g = toGray frame + size@(Size w h) <- get windowSize + gg <- mallocBytes $ fromIntegral (w * h) + g *| (gg, size) + drawPixels size (PixelData Luminance UnsignedByte gg) + addTimerCallback 40 $ timer camera + flush + +display :: DisplayCallback +display = do + flush + +keyboard :: KeyboardMouseCallback +keyboard (Char '\27') Down _ _ = exitWith ExitSuccess + +main :: IO () +main = do + initCursor + enterMovies + camera <- with Rect { top = 0 + , left = 0 + , bottom = 480 + , right = 640 } $ \r -> newSGChannel r + getArgsAndInitialize + initialWindowPosition $= Position 100 100 + initialWindowSize $= Size 640 480 + initialDisplayMode $= [SingleBuffered, RGBMode] + createWindow "Minimung" + clearColor $= Color4 0 0 0 0 + shadeModel $= Flat + rowAlignment Unpack $= 1 + displayCallback $= display + keyboardMouseCallback $= Just keyboard + addTimerCallback 40 $ timer camera + mainLoop diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/minimung.cabal b/minimung.cabal new file mode 100644 --- /dev/null +++ b/minimung.cabal @@ -0,0 +1,31 @@ +Name: minimung +Version: 0.0 +Cabal-Version: >= 1.2 +License: BSD3 +License-File: LICENSE +Synopsis: Shows how to run grabber on Mac OS X +Category: Foreign, Graphics +Description: + minimung is capable to do real time CIF?? + . + Only 'Mac', 'Mac.Carbon', 'Mac.QuickDraw', 'Mac.QuickTime' are stable and good. The rest is quick hack + . +Author: Yakov Zaytsev +Maintainer: Yakov Zaytsev +build-type: Simple +extra-source-files:LICENSE +-- if os(darwin) +Executable minimung + build-depends: base >= 4.0 && < 4.2, haskell98, unix, GLUT + Main-Is: Minimung.hs + hs-source-dirs: . + Other-modules: Mac + Mac.Carbon + Mac.QuickTime + Mac.QuickDraw + Data.Image + Data.Geometry + Data.Camera + frameworks: QuickTime Carbon + ld-options: -threaded +-- ghc-options: -fglasgow-exts