minimung-0.0: Mac.hs

-- |
-- 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