diff --git a/Data/Array/Accelerate/IO/BMP.hs b/Data/Array/Accelerate/IO/BMP.hs --- a/Data/Array/Accelerate/IO/BMP.hs +++ b/Data/Array/Accelerate/IO/BMP.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.IO.BMP -- Copyright : [2012..2014] Trevor L. McDonell @@ -67,41 +69,61 @@ -- type RGBA32 = Word32 --- | Unpack a 'RGBA32' value into a tuple of (Red, Green, Blue, Alpha) values. +-- | Unpack a (little-endian) 'RGBA32' value into a tuple of (Red, Green, Blue, +-- Alpha) values. -- -unpackRGBA32 :: Exp RGBA32 -> Exp (Word8, Word8, Word8, Word8) -unpackRGBA32 rgba = - let r = A.fromIntegral $ rgba .&. 0xFF - g = A.fromIntegral $ (rgba `div` 0x100) .&. 0xFF - b = A.fromIntegral $ (rgba `div` 0x10000) .&. 0xFF - a = A.fromIntegral $ (rgba `div` 0x1000000) .&. 0xFF +unpackRGBA32, unpackRGBA32le, unpackRGBA32be + :: Exp RGBA32 + -> Exp (Word8, Word8, Word8, Word8) +unpackRGBA32 = unpackRGBA32le + +unpackRGBA32le rgba = + let a = A.fromIntegral (rgba `A.shiftR` 24) + b = A.fromIntegral (rgba `A.shiftR` 16) + g = A.fromIntegral (rgba `A.shiftR` 8) + r = A.fromIntegral rgba in lift (r, g, b, a) +unpackRGBA32be rgba = + let r = A.fromIntegral (rgba `A.shiftR` 24) + g = A.fromIntegral (rgba `A.shiftR` 16) + b = A.fromIntegral (rgba `A.shiftR` 8) + a = A.fromIntegral rgba + in + lift (r, g, b, a) --- | Promote a tuple of (Red, Green, Blue, Alpha) values into a packed 'RGBA32' --- value. + +-- | Promote a tuple of (Red, Green, Blue, Alpha) values into a packed +-- (little-endian) 'RGBA32' value. -- -packRGBA32 :: Exp (Word8, Word8, Word8, Word8) -> Exp RGBA32 -packRGBA32 rgba = - let (r', g', b', a') = unlift rgba - r = A.fromIntegral r' - g = (A.fromIntegral g') * 0x100 - b = (A.fromIntegral b') * 0x10000 - a = (A.fromIntegral a') * 0x1000000 - in - r + g + b + a +packRGBA32, packRGBA32le, packRGBA32be + :: Exp (Word8, Word8, Word8, Word8) + -> Exp RGBA32 +packRGBA32 = packRGBA32le +packRGBA32le (unlift -> (r, g, b, a)) + = A.fromIntegral a `A.shiftL` 24 + .|. A.fromIntegral b `A.shiftL` 16 + .|. A.fromIntegral g `A.shiftL` 8 + .|. A.fromIntegral r +packRGBA32be (unlift -> (r, g, b, a)) + = A.fromIntegral r `A.shiftL` 24 + .|. A.fromIntegral g `A.shiftL` 16 + .|. A.fromIntegral b `A.shiftL` 8 + .|. A.fromIntegral a + + -- | Convert an RGBA colour to its luminance value in the range [0..1]. -- luminanceOfRGBA32 :: (Elt a, IsFloating a) => Exp RGBA32 -> Exp a -luminanceOfRGBA32 rgba = - let r = 0.3 * A.fromIntegral (rgba .&. 0xFF) - g = 0.59 * A.fromIntegral ((rgba `div` 0x100) .&. 0xFF) - b = 0.11 * A.fromIntegral ((rgba `div` 0x10000) .&. 0xFF) +luminanceOfRGBA32 (unlift . unpackRGBA32 -> (r, g, b, _a :: Exp Word8)) = + let r' = 0.3 * A.fromIntegral r + g' = 0.59 * A.fromIntegral g + b' = 0.11 * A.fromIntegral b in - (r + g + b) / 255 + (r' + g' + b') / 255 -- | Convert a value in the range [0..1] to a grey RGB colour. @@ -109,24 +131,19 @@ rgba32OfLuminance :: (Elt a, IsFloating a) => Exp a -> Exp RGBA32 rgba32OfLuminance val = let v = A.truncate (255 * val) -- (0 `A.max` val `A.min` 1) - r = v - g = v * 0x100 - b = v * 0x10000 - a = 0xFF000000 in - r + g + b + a + packRGBA32 (lift (v, v, v, constant 0xFF)) -- | Promote a tuple of (Red, Green, Blue, Alpha) values in the range [0..1] -- into a packed 'RGBA32'. -- rgba32OfFloat :: (Elt a, IsFloating a) => Exp (a, a, a, a) -> Exp RGBA32 -rgba32OfFloat rgba = - let (r, g, b, a) = unlift rgba - r' = A.truncate (255 * r) * 0x1000000 - g' = A.truncate (255 * g) * 0x10000 - b' = A.truncate (255 * b) * 0x100 - a' = A.truncate (255 * a) +rgba32OfFloat (unlift -> (r,g,b,a)) = + let r' = A.truncate (255 * r) + g' = A.truncate (255 * g) + b' = A.truncate (255 * b) + a' = A.truncate (255 * a) in - r' + g' + b' + a' + packRGBA32 (lift (r', g', b', a')) diff --git a/Data/Array/Accelerate/IO/ByteString.hs b/Data/Array/Accelerate/IO/ByteString.hs --- a/Data/Array/Accelerate/IO/ByteString.hs +++ b/Data/Array/Accelerate/IO/ByteString.hs @@ -29,8 +29,8 @@ -- fromByteString :: (Shape sh, Elt e) => sh -> ByteStrings (EltRepr e) -> IO (Array sh e) fromByteString sh byteStrings = do - let arr = allocateArray sh - copier = let ((_,f),_,_) = blockCopyFunGenerator arr in f + arr <- allocateArray sh + let copier = let ((_,f),_,_) = blockCopyFunGenerator arr in f copier byteStrings return arr diff --git a/Data/Array/Accelerate/IO/Ptr.hs b/Data/Array/Accelerate/IO/Ptr.hs --- a/Data/Array/Accelerate/IO/Ptr.hs +++ b/Data/Array/Accelerate/IO/Ptr.hs @@ -35,8 +35,8 @@ -- fromPtr :: (Shape sh, Elt e) => sh -> BlockPtrs (EltRepr e) -> IO (Array sh e) fromPtr sh blkPtrs = do - let arr = allocateArray sh - copier = let ((f,_),_,_) = blockCopyFunGenerator arr in f + arr <- allocateArray sh + let copier = let ((f,_),_,_) = blockCopyFunGenerator arr in f copier blkPtrs return arr @@ -94,8 +94,8 @@ -- toArray :: (Shape sh, Elt e) => sh -> BlockCopyFuns (EltRepr e) -> IO (Array sh e) toArray sh blockCopyFuns = do - let arr = allocateArray sh - copier = let (_,_,f) = blockCopyFunGenerator arr in f + arr <- allocateArray sh + let copier = let (_,_,f) = blockCopyFunGenerator arr in f copier blockCopyFuns return arr diff --git a/accelerate-io.cabal b/accelerate-io.cabal --- a/accelerate-io.cabal +++ b/accelerate-io.cabal @@ -1,7 +1,7 @@ Name: accelerate-io -Version: 0.15.0.0 +Version: 0.15.1.0 Cabal-version: >= 1.6 -Tested-with: GHC == 7.6.* +Tested-with: GHC >= 7.8 Build-type: Simple Synopsis: Read and write Accelerate arrays in various formats @@ -16,7 +16,7 @@ License-file: LICENSE Author: Manuel M T Chakravarty, Gabriele Keller, - Sean Lee, + Sean Seefried, Trevor L. McDonell Maintainer: Manuel M T Chakravarty Homepage: https://github.com/AccelerateHS/accelerate-io @@ -25,9 +25,7 @@ Category: Compilers/Interpreters, Concurrency, Data, Parallelism Stability: Experimental -Extra-source-files: include/accelerate.h - Flag bounds-checks Description: Enable bounds checking Default: True @@ -41,10 +39,9 @@ Default: False Library - Include-Dirs: include - Build-depends: accelerate == 0.15.*, + Build-depends: accelerate == 0.15.1.*, array >= 0.3, - base >= 4.6 && < 4.8, + base >= 4.7 && < 4.9, bmp >= 1.2, bytestring >= 0.9, repa >= 3.2, @@ -76,7 +73,9 @@ -- -- Extensions: -Source-repository head - Type: git - Location: git://github.com/AccelerateHS/accelerate-io.git +Source-repository this + type: git + location: git://github.com/AccelerateHS/accelerate-io.git + branch: release/0.15 + tag: 0.15.1.0 diff --git a/include/accelerate.h b/include/accelerate.h deleted file mode 100644 --- a/include/accelerate.h +++ /dev/null @@ -1,25 +0,0 @@ - -#ifndef NOT_ACCELERATE_MODULE -import qualified Data.Array.Accelerate.Internal.Check as Ck -#endif - -#define ERROR(f) (Ck.f __FILE__ __LINE__) -#define ASSERT (Ck.assert __FILE__ __LINE__) -#define ENSURE (Ck.f __FILE__ __LINE__) -#define CHECK(f) (Ck.f __FILE__ __LINE__) - -#define BOUNDS_ERROR(f) (ERROR(f) Ck.Bounds) -#define BOUNDS_ASSERT (ASSERT Ck.Bounds) -#define BOUNDS_ENSURE (ENSURE Ck.Bounds) -#define BOUNDS_CHECK(f) (CHECK(f) Ck.Bounds) - -#define UNSAFE_ERROR(f) (ERROR(f) Ck.Unsafe) -#define UNSAFE_ASSERT (ASSERT Ck.Unsafe) -#define UNSAFE_ENSURE (ENSURE Ck.Unsafe) -#define UNSAFE_CHECK(f) (CHECK(f) Ck.Unsafe) - -#define INTERNAL_ERROR(f) (ERROR(f) Ck.Internal) -#define INTERNAL_ASSERT (ASSERT Ck.Internal) -#define INTERNAL_ENSURE (ENSURE Ck.Internal) -#define INTERNAL_CHECK(f) (CHECK(f) Ck.Internal) -