packages feed

minimung (empty) → 0.0

raw patch · 11 files changed

+1007/−0 lines, 11 filesdep +GLUTdep +basedep +haskell98setup-changed

Dependencies added: GLUT, base, haskell98, unix

Files

+ Data/Camera.hs view
@@ -0,0 +1,13 @@+-- |+-- Module     : Video.Camera+-- Maintainer : Yakov Zaytsev <yakov@yakov.cc>+-- Stability  : experimental+--++module Data.Camera (+               Camera+              ) where++import Data.Image++type Camera a = IO (Image a)
+ Data/Geometry.hs view
@@ -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)]]
+ Data/Image.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ExistentialQuantification #-}++-- |+-- Module     : Data.Image+-- Maintainer : Yakov Zaytsev <yakov@yakov.cc>+-- 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)  -- ???
+ LICENSE view
@@ -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.
+ Mac.hs view
@@ -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+
+ Mac/Carbon.hsc view
@@ -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 <Carbon/Carbon.h>++-- | 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+
+ Mac/QuickDraw.hsc view
@@ -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 <QuickTime/QuickTime.h>++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.+--+-- <http://developer.apple.com/documentation/QuickTime/Reference/QTRef_DataTypes/Reference/reference.html#//apple_ref/doc/c_ref/PixMap>+--+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+
+ Mac/QuickTime.hsc view
@@ -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 <QuicKTime/QuickTime.h>++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++
+ Minimung.hs view
@@ -0,0 +1,66 @@+-- |+-- Maintainer : Yakov Zaytsev <yakov@yakov.cc>+-- 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
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ minimung.cabal view
@@ -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 <yakov@yakov.cc>+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