module Data.Array.Repa.IO.BMP
( readImageFromBMP
, readComponentsFromBMP
, readComponentsListFromBMP
, readMatrixFromGreyscaleBMP
, writeImageToBMP
, writeComponentsToBMP
, writeComponentsListToBMP
, writeMatrixToGreyscaleBMP)
where
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 = force2
$ 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)
readComponentsListFromBMP
:: FilePath
-> IO (Either Error [Array DIM2 Word8])
readComponentsListFromBMP filePath
= do eComps <- readComponentsFromBMP filePath
case eComps of
Left err
-> return $ Left err
Right (arrRed, arrGreen, arrBlue)
-> return $ Right [arrRed, arrGreen, arrBlue]
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
= force2 $ traverse arr shapeFn
(\get (sh :. x) -> get (sh :. (x * 4)))
arrGreen
= force2 $ traverse arr shapeFn
(\get (sh :. x) -> get (sh :. (x * 4 + 1)))
arrBlue
= force2 $ traverse arr shapeFn
(\get (sh :. x) -> get (sh :. (x * 4 + 2)))
in [arrRed, arrGreen, arrBlue] `deepSeqArrays` (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
:: forall a. (Num a, Elt a, Fractional a, RealFrac a)
=> FilePath
-> Array DIM2 a
-> IO ()
writeMatrixToGreyscaleBMP fileName arr
= let arrNorm = normalisePositive01 arr
scale x = fromIntegral (truncate (x * 255) :: Int)
arrWord8 = A.map scale arrNorm
in writeComponentsToBMP fileName arrWord8 arrWord8 arrWord8
writeComponentsListToBMP
:: FilePath
-> [Array DIM2 Word8]
-> IO ()
writeComponentsListToBMP filePath comps
| [red, green, blue] <- comps
= writeComponentsToBMP filePath red green blue
| otherwise
= error "Data.Array.Repa.IO.BMP.writeComponentsListToBMP: wrong number of components"
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 width height
$ A.toByteString arrImage
in writeBMP fileName bmp
where Z :. height :. width :. comps
= extent arrImage
normalisePositive01
:: (Shape sh, 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