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 = Word32
type ILboolean = Word8
type ILenum = Word32
type ILint = Int32
type ILubyte = Word8
newtype ImageName = ImageName ILuint
deriving (Show)
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 :: ILenum
il_RGB = (6407)
il_RGBA = (6408)
il_BGR = (32992)
il_BGRA = (32993)
il_LUMINANCE = (6409)
il_IMAGE_HEIGHT, il_IMAGE_WIDTH :: ILenum
il_IMAGE_FORMAT, il_IMAGE_TYPE :: ILenum
il_UNSIGNED_BYTE :: ILenum
il_IMAGE_HEIGHT = (3557)
il_IMAGE_WIDTH = (3556)
il_IMAGE_FORMAT = (3562)
il_IMAGE_TYPE = (3563)
il_UNSIGNED_BYTE = (5121)
foreign import ccall unsafe "ilConvertImage" ilConvertImageC
:: ILenum -> ILenum -> IO ILboolean
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
pixelType <- fromIntegral <$> ilGetIntegerC il_IMAGE_TYPE
case fromIntegral format :: ILenum of
(6407) -> do
convert il_RGB pixelType
RGB <$> pixelsToArray (Z :. height :. width :. 3)
(6408) -> do
convert il_RGBA pixelType
RGBA <$> pixelsToArray (Z :. height :. width :. 4)
(32992) -> do
convert il_BGR pixelType
BGR <$> pixelsToArray (Z :. height :. width :. 3)
(32993) -> do
convert il_BGRA pixelType
BGRA <$> pixelsToArray (Z :. height :. width :. 4)
(6409) -> do
convert il_LUMINANCE pixelType
Grey <$> pixelsToArray (Z :. height :. width)
_ -> do
ilConvertImage il_RGBA il_UNSIGNED_BYTE
RGBA <$> pixelsToArray (Z :. height :. width :. 4)
where
convert format pixelType
| pixelType == il_UNSIGNED_BYTE = return ()
| otherwise = ilConvertImage format il_UNSIGNED_BYTE
pixelsToArray dstExtent = do
pixels <- ilGetDataC
managedPixels <- newForeignPtr pixels (ilDeleteImage name)
return $! fromForeignPtr dstExtent managedPixels
ilConvertImage format pixelType = do
success <- (0 /=) <$> ilConvertImageC format pixelType
when (not success) $
error "Unable to convert the image to a supported 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