Capture.hs

{- |

Module      :  Graphics.Rendering.OpenGL.Capture
Copyright   :  (c) Claude Heiland-Allen 2012
License     :  BSD3

Maintainer  :  claude@mathr.co.uk
Stability   :  provisional
Portability :  portable

Simple image capture from OpenGL.

-}
module Graphics.Rendering.OpenGL.Capture (capturePPM) where

import Control.Monad (forM_)
import Foreign (allocaBytes, plusPtr)

import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString as BS
import Data.ByteString (ByteString)

import Graphics.Rendering.OpenGL

{- |  Capture the current viewport to a ByteString in PPM P6 format.
      Correctly handles pixel alignment for oddly-sized regions.
      Corrects the image orientation so that the origin is top left.
-}
--    This is too monolithic - patches welcome.
capturePPM :: IO ByteString
capturePPM = do
  (p0, s0@(Size vw vh)) <- get viewport
  let p6 = "P6\n" ++ show vw ++ " " ++ show vh ++ "\n255\n"
  allocaBytes (fromIntegral (vw*vh*3)) $ \ptr -> do
    preservingBufferBinding PixelPackBuffer $ do
      -- pack buffer   needs OpenGL version >= 2.1
      bindBuffer PixelPackBuffer $= Nothing
      -- client attrib needs OpenGL version >= 1.1
      preservingClientAttrib [PixelStoreAttributes] $ do
        -- FIXME what else needs setting to avoid crashes or bad output?
        rowAlignment Pack $= 1
        readPixels p0 s0 $ PixelData RGB UnsignedByte ptr
    px <- BSI.create (fromIntegral $ vw * vh * 3) $ \d ->
      forM_ [0..vh-1] $ \y ->
        BSI.memcpy
          (d `plusPtr` fromIntegral (y*vw*3))
          (ptr `plusPtr` fromIntegral ((vh-1-y)*vw*3))
          (fromIntegral (vw*3))
    return $ BS.pack (map (toEnum . fromEnum) p6) `BS.append` px

--    This should check OpenGL version >= 2.1 - patches welcome.
preservingBufferBinding :: BufferTarget -> IO a -> IO a
preservingBufferBinding target action = do
  buffer <- get $ bindBuffer target
  result <- action
  bindBuffer target $= buffer
  return result