module Data.Array.Repa.IO.BMP
( readImageFromBMP
, readComponentsFromBMP
, readMatrixFromGreyscaleBMP
, writeImageToBMP
, writeComponentsToBMP
, writeMatrixToGreyscaleBMP)
where
import qualified Data.Array.Parallel.Unlifted as U
import Data.Array.Repa as A
import Data.Array.Repa.ByteString as A
import Prelude as P
import Codec.BMP
import Data.Word
readMatrixFromGreyscaleBMP
:: FilePath
-> IO (Either Error (Array DIM2 Double))
readMatrixFromGreyscaleBMP filePath
= do eComps <- readComponentsFromBMP filePath
case eComps of
Left err -> return $ Left err
Right (arrRed, arrGreen, arrBlue)
-> let arr = force
$ A.fromFunction (extent arrRed)
(\ix -> sqrt ( (fromIntegral (arrRed !: ix) / 255) ^ (2 :: Int)
+ (fromIntegral (arrGreen !: ix) / 255) ^ (2 :: Int)
+ (fromIntegral (arrBlue !: ix) / 255) ^ (2 :: Int)))
in arr `deepSeqArray` return (Right arr)
readComponentsFromBMP
:: FilePath
-> IO (Either Error (Array DIM2 Word8, Array DIM2 Word8, Array DIM2 Word8))
readComponentsFromBMP filePath
= do ebmp <- readBMP filePath
case ebmp of
Left err -> return $ Left err
Right bmp -> return $ Right (readComponentsFromBMP' bmp)
readComponentsFromBMP' bmp
= let (width, height) = bmpDimensions bmp
arr = A.fromByteString (Z :. height :. width * 4)
$ unpackBMPToRGBA32 bmp
shapeFn _ = Z :. height :. width
arrRed
= traverse arr shapeFn
(\get (sh :. x) -> get (sh :. (x * 4)))
arrGreen
= traverse arr shapeFn
(\get (sh :. x) -> get (sh :. (x * 4 + 1)))
arrBlue
= traverse arr shapeFn
(\get (sh :. x) -> get (sh :. (x * 4 + 2)))
in (arrRed, arrGreen, arrBlue)
readImageFromBMP
:: FilePath
-> IO (Either Error (Array DIM3 Word8))
readImageFromBMP filePath
= do ebmp <- readBMP filePath
case ebmp of
Left err -> return $ Left err
Right bmp -> return $ Right (readImageFromBMP' bmp)
readImageFromBMP' bmp
= let (width, height) = bmpDimensions bmp
arr = fromByteString (Z :. height :. width :. 4)
$ unpackBMPToRGBA32 bmp
in arr
writeMatrixToGreyscaleBMP
:: FilePath
-> Array DIM2 Double
-> IO ()
writeMatrixToGreyscaleBMP fileName arr
= let arrNorm = normalisePositive01 arr
scale :: Double -> Word8
scale x = fromIntegral (truncate (x * 255) :: Int)
arrWord8 = A.map scale arrNorm
in writeComponentsToBMP fileName arrWord8 arrWord8 arrWord8
writeComponentsToBMP
:: FilePath
-> Array DIM2 Word8
-> Array DIM2 Word8
-> Array DIM2 Word8
-> IO ()
writeComponentsToBMP fileName arrRed arrGreen arrBlue
| not $ ( extent arrRed == extent arrGreen
&& extent arrGreen == extent arrBlue)
= error "Data.Array.Repa.IO.BMP.writeComponentsToBMP: arrays don't have same extent"
| otherwise
= do let Z :. height :. width
= extent arrRed
let arrAlpha = fromFunction (extent arrRed) (\_ -> 255)
let arrRGBA = interleave4 arrRed arrGreen arrBlue arrAlpha
let bmp = packRGBA32ToBMP width height
$ A.toByteString arrRGBA
writeBMP fileName bmp
writeImageToBMP
:: FilePath
-> Array DIM3 Word8
-> IO ()
writeImageToBMP fileName arrImage
| comps /= 4
= error "Data.Array.Repa.IO.BMP: lowest order dimension must be 4"
| otherwise
= let bmp = packRGBA32ToBMP height width
$ A.toByteString arrImage
in writeBMP fileName bmp
where Z :. height :. width :. comps
= extent arrImage
normalisePositive01
:: (Shape sh, U.Elt a, Fractional a, Ord a)
=> Array sh a
-> Array sh a
normalisePositive01 arr
= let mx = foldAll max 0 arr
elemFn x
| x >= 0 = x / mx
| otherwise = x
in mx `seq`
if mx == 0
then arr
else A.map elemFn arr