module Data.Array.Repa.IO.DevIL (
Image (..)
, IL, runIL
, readImage, writeImage
) where
import Control.Applicative (Applicative, (<$>))
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Int
import Data.Word
import Foreign.C.String (CString, withCString)
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Concurrent (newForeignPtr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (peek)
import Foreign.Marshal.Utils (with)
import Data.Array.Repa (Array (..), Z (..), (:.) (..), DIM2, DIM3, extent)
import Data.Array.Repa.Repr.ForeignPtr (F, fromForeignPtr, toForeignPtr)
type ILuint = Word32
type ILsizei = Word64
type ILboolean = Word8
type ILenum = Word32
type ILint = Int32
type ILubyte = Word8
newtype ImageName = ImageName ILuint
data Image = RGBA (Array F DIM3 Word8)
| RGB (Array F DIM3 Word8)
| BGRA (Array F DIM3 Word8)
| BGR (Array F DIM3 Word8)
| Grey (Array F DIM2 Word8)
newtype IL a = IL (IO a)
deriving (Monad, MonadIO, Functor, Applicative)
runIL :: IL a -> IO a
runIL (IL a) = ilInit >> a
readImage :: FilePath -> IL Image
readImage f = liftIO $ do
name <- ilGenImageName
ilBindImage name
success <- ilLoadImage f
when (not success) $
error "Unable to load the image."
toRepa name
writeImage :: FilePath -> Image -> IL ()
writeImage f i = liftIO $ do
name <- ilGenImageName
ilBindImage name
successCopy <- fromRepa i
when (not successCopy) $
error "Unable to copy the image to the DevIL buffer."
successSave <- ilSaveImage f
when (not successSave) $
error "Unable to the save the image to the file."
ilDeleteImage name
foreign import ccall unsafe "ilInit" ilInitC :: IO ()
foreign import ccall unsafe "ilOriginFunc" ilOriginFuncC :: ILenum -> IO ILboolean
foreign import ccall unsafe "ilEnable" ilEnableC :: ILenum -> IO ILboolean
ilInit :: IO ()
ilInit = do
ilInitC
_ <- ilOriginFuncC (1537)
_ <- ilEnableC (1536)
return ()
foreign import ccall unsafe "ilGenImages" ilGenImagesC
:: ILsizei -> Ptr ILuint -> IO ()
ilGenImageName :: IO ImageName
ilGenImageName = do
alloca $ \pName -> do
ilGenImagesC 1 pName
name <- peek pName
return $! ImageName name
foreign import ccall unsafe "ilBindImage" ilBindImageC :: ILuint -> IO ()
ilBindImage :: ImageName -> IO ()
ilBindImage (ImageName name) = ilBindImageC name
foreign import ccall unsafe "ilLoadImage" ilLoadImageC :: CString -> IO ILboolean
ilLoadImage :: FilePath -> IO Bool
ilLoadImage f = (0 /=) <$> withCString f ilLoadImageC
foreign import ccall unsafe "ilGetInteger" ilGetIntegerC :: ILenum -> IO ILint
il_RGB, il_RGBA, il_BGR, il_BGRA, il_LUMINANCE :: ILint
il_RGB = (6407)
il_RGBA = (6408)
il_BGR = (32992)
il_BGRA = (32993)
il_LUMINANCE = (6409)
il_IMAGE_HEIGHT, il_IMAGE_WIDTH, il_IMAGE_FORMAT, il_UNSIGNED_BYTE :: ILenum
il_IMAGE_HEIGHT = (3557)
il_IMAGE_WIDTH = (3556)
il_IMAGE_FORMAT = (3562)
il_UNSIGNED_BYTE = (5121)
foreign import ccall unsafe "ilGetData" ilGetDataC :: IO (Ptr ILubyte)
toRepa :: ImageName -> IO Image
toRepa name = do
width' <- ilGetIntegerC il_IMAGE_WIDTH
height' <- ilGetIntegerC il_IMAGE_HEIGHT
let (width, height) = (fromIntegral width', fromIntegral height')
format <- ilGetIntegerC il_IMAGE_FORMAT
pixels <- ilGetDataC
managedPixels <- newForeignPtr pixels (ilDeleteImage name)
return $! imageFromFormat format width height managedPixels
where
imageFromFormat format width height managedPixels
| format == il_RGB =
RGB $! fromForeignPtr (Z :. height :. width :. 3) managedPixels
| format == il_RGBA =
RGBA $! fromForeignPtr (Z :. height :. width :. 4) managedPixels
| format == il_BGR =
BGR $! fromForeignPtr (Z :. height :. width :. 3) managedPixels
| format == il_BGRA =
BGRA $! fromForeignPtr (Z :. height :. width :. 4) managedPixels
| format == il_LUMINANCE =
Grey $! fromForeignPtr (Z :. height :. width) managedPixels
| otherwise =
error "Unsupported image format."
foreign import ccall unsafe "ilTexImage" ilTexImageC
:: ILuint -> ILuint -> ILuint
-> ILubyte -> ILenum -> ILenum
-> Ptr ()
-> IO ILboolean
fromRepa :: Image -> IO Bool
fromRepa (RGB i) =
let Z :. h :. w :. _ = extent i
in (0 /=) <$> (withForeignPtr (toForeignPtr i) $ \p ->
ilTexImageC (fromIntegral w) (fromIntegral h) 1 3
(fromIntegral il_RGB) il_UNSIGNED_BYTE (castPtr p))
fromRepa (RGBA i) =
let Z :. h :. w :. _ = extent i
in (0 /=) <$> (withForeignPtr (toForeignPtr i) $ \p ->
ilTexImageC (fromIntegral w) (fromIntegral h) 1 4
(fromIntegral il_RGBA) il_UNSIGNED_BYTE (castPtr p))
fromRepa (BGR i) =
let Z :. h :. w :. _ = extent i
in (0 /=) <$> (withForeignPtr (toForeignPtr i) $ \p ->
ilTexImageC (fromIntegral w) (fromIntegral h) 1 3
(fromIntegral il_BGR) il_UNSIGNED_BYTE (castPtr p))
fromRepa (BGRA i) =
let Z :. h :. w :. _ = extent i
in (0 /=) <$> (withForeignPtr (toForeignPtr i) $ \p ->
ilTexImageC (fromIntegral w) (fromIntegral h) 1 4
(fromIntegral il_BGRA) il_UNSIGNED_BYTE (castPtr p))
fromRepa (Grey i) =
let Z :. h :. w = extent i
in (0 /=) <$> (withForeignPtr (toForeignPtr i) $ \p ->
ilTexImageC (fromIntegral w) (fromIntegral h) 1 1
(fromIntegral il_LUMINANCE) il_UNSIGNED_BYTE
(castPtr p))
foreign import ccall unsafe "ilSaveImage" ilSaveImageC :: CString -> IO ILboolean
ilSaveImage :: FilePath -> IO Bool
ilSaveImage file = do
(0 /=) <$> withCString file ilSaveImageC
foreign import ccall unsafe "ilDeleteImages" ilDeleteImagesC
:: ILsizei -> Ptr ILuint -> IO ()
ilDeleteImage :: ImageName -> IO ()
ilDeleteImage (ImageName name) =
with name $ \pName ->
ilDeleteImagesC 1 pName