module Data.Array.Repa.IO.BMP
( readImageFromBMP
, writeImageToBMP)
where
import Data.Array.Repa as R
import Data.Array.Repa.Unsafe as R
import Data.Array.Repa.Repr.ForeignPtr as R
import Data.Array.Repa.Repr.ByteString as R
import Data.Vector.Unboxed as U
import Prelude as P
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Data.ByteString.Unsafe as B
import Codec.BMP
import Data.Word
readImageFromBMP
:: FilePath
-> IO (Either Error (Array U DIM2 (Word8, Word8, Word8)))
readImageFromBMP filePath
= do ebmp <- readBMP filePath
case ebmp of
Left err -> return $ Left err
Right bmp
-> do arr <- readImageFromBMP' bmp
return $ Right arr
readImageFromBMP' bmp
= do let (width, height) = bmpDimensions bmp
let arr = R.fromByteString (Z :. height :. width * 4)
$ unpackBMPToRGBA32 bmp
let shapeFn _ = Z :. height :. width
vecRed <- computeP
$ unsafeTraverse arr shapeFn
(\get (sh :. x) -> get (sh :. (x * 4)))
vecGreen <- computeP
$ unsafeTraverse arr shapeFn
(\get (sh :. x) -> get (sh :. (x * 4 + 1)))
vecBlue <- computeP
$ unsafeTraverse arr shapeFn
(\get (sh :. x) -> get (sh :. (x * 4 + 2)))
let vecRGB = U.zip3 (toUnboxed vecRed)
(toUnboxed vecGreen)
(toUnboxed vecBlue)
return $ fromUnboxed (Z :. height :. width) vecRGB
writeImageToBMP
:: FilePath
-> Array U DIM2 (Word8, Word8, Word8)
-> IO ()
writeImageToBMP fileName arrRGB
= do let sh@(Z :. height :. width)
= extent arrRGB
let (vecRed, vecGreen, vecBlue)
= U.unzip3 $ toUnboxed arrRGB
ptr <- mallocBytes (height * width * 4)
fptr <- newForeignPtr finalizerFree ptr
computeIntoP fptr
$ interleave4
(fromUnboxed sh vecRed)
(fromUnboxed sh vecGreen)
(fromUnboxed sh vecBlue)
(fromFunction sh (\_ -> 255))
withForeignPtr fptr
$ \ptr' -> do
bs <- unsafePackCStringFinalizer ptr' (width * height * 4) (return ())
let bmp = packRGBA32ToBMP width height bs
writeBMP fileName bmp