diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,14 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [0.4.0.0] - 2020-08-26 +### Changed + * update for accelerate-1.3 + * data types are stored in AoS style + +### Added + * pattern synonyms for unpacking colour components + ## [0.3.0.0] - 2018-04-03 ### Changed * update to accelerate-1.2 @@ -18,6 +26,7 @@ * initial release +[0.4.0.0]: https://github.com/tmcdonell/colour-accelerate/compare/0.3.0.0...v0.4.0.0 [0.3.0.0]: https://github.com/tmcdonell/colour-accelerate/compare/0.2.0.0...0.3.0.0 [0.2.0.0]: https://github.com/tmcdonell/colour-accelerate/compare/0.1.0.0...0.2.0.0 [0.1.0.0]: https://github.com/tmcdonell/colour-accelerate/compare/6b2dc2e55bc0503aa4c94b883f6b608aaa734101...0.1.0.0 diff --git a/Data/Array/Accelerate/Data/Colour/HSL.hs b/Data/Array/Accelerate/Data/Colour/HSL.hs --- a/Data/Array/Accelerate/Data/Colour/HSL.hs +++ b/Data/Array/Accelerate/Data/Colour/HSL.hs @@ -1,24 +1,24 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif -- | -- Module : Data.Array.Accelerate.Data.Colour.HSL --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -32,6 +32,7 @@ Colour, HSL(..), + pattern HSL_, hsl, clamp, @@ -43,16 +44,14 @@ ) where import Data.Array.Accelerate as A hiding ( clamp ) -import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Product ( TupleIdx(..), IsProduct(..) ) -import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..) ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Primitive.Vec import Data.Array.Accelerate.Data.Colour.RGB ( RGB(..) ) import Data.Array.Accelerate.Data.Colour.Names as C import Data.Functor import Data.Typeable -import Prelude ( fromInteger ) -- ghc < 8 bug import qualified Prelude as P @@ -147,32 +146,25 @@ -- HSL colour space -- data HSL a = HSL a a a - deriving (P.Show, P.Eq, Functor, Typeable) - --- Represent colours in Accelerate as a 3-tuple --- -type instance EltRepr (HSL a) = EltRepr (a, a, a) + deriving (P.Show, P.Eq, Functor, Typeable, Generic) -instance Elt a => Elt (HSL a) where - eltType (_ :: HSL a) = eltType (undefined :: (a,a,a)) - toElt c = let (h,s,l) = toElt c in HSL h s l - fromElt (HSL h s l) = fromElt (h,s,l) +pattern HSL_ :: (Elt (HSL a), Elt a, VecElt a, EltR (HSL a) ~ Vec3 a) => Exp a -> Exp a -> Exp a -> Exp (HSL a) +pattern HSL_ h s l = V3 h s l +{-# COMPLETE HSL_ #-} -instance Elt a => IsProduct Elt (HSL a) where - type ProdRepr (HSL a) = ((((),a), a), a) - fromProd _ (HSL h s l) = ((((), h), s), l) - toProd _ ((((),h),s),l) = HSL h s l - prod cst _ = prod cst (undefined :: (a,a,a)) +instance Elt (HSL Float) where + type EltR (HSL Float) = Vec3 Float + eltR = eltR @(Vec3 Float) + tagsR = tagsR @(Vec3 Float) + toElt (Vec3 r g b) = HSL r g b + fromElt (HSL r g b) = Vec3 r g b -instance (Lift Exp a, Elt (Plain a)) => Lift Exp (HSL a) where - type Plain (HSL a) = HSL (Plain a) - lift (HSL h s l) = Exp . Tuple $ NilTup `SnocTup` lift h `SnocTup` lift s `SnocTup` lift l +instance Lift Exp (HSL (Exp Float)) where + type Plain (HSL (Exp Float)) = HSL Float + lift (HSL h s l) = HSL_ h s l -instance Elt a => Unlift Exp (HSL (Exp a)) where - unlift c = let h = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` c - s = Exp $ SuccTupIdx ZeroTupIdx `Prj` c - l = Exp $ ZeroTupIdx `Prj` c - in HSL h s l +instance Unlift Exp (HSL (Exp Float)) where + unlift (HSL_ h s l) = HSL h s l instance P.Num a => P.Num (HSL a) where (+) (HSL h1 s1 v1 ) (HSL h2 s2 v2) @@ -192,7 +184,7 @@ fromInteger i = let f = P.fromInteger i - in HSL f f f + in HSL f f f instance (P.Num a, P.Fractional a) => P.Fractional (HSL a) where (/) (HSL h1 s1 l1) (HSL h2 s2 l2) @@ -203,23 +195,25 @@ fromRational r = let f = P.fromRational r - in HSL f f f + in HSL f f f -instance {-# OVERLAPS #-} A.Num a => P.Num (Exp (HSL a)) where +instance (A.Num a, Unlift Exp (HSL (Exp a)), Plain (HSL (Exp a)) ~ HSL a) + => P.Num (Exp (HSL a)) where (+) = lift2 ((+) :: HSL (Exp a) -> HSL (Exp a) -> HSL (Exp a)) (-) = lift2 ((-) :: HSL (Exp a) -> HSL (Exp a) -> HSL (Exp a)) (*) = lift2 ((*) :: HSL (Exp a) -> HSL (Exp a) -> HSL (Exp a)) abs = lift1 (abs :: HSL (Exp a) -> HSL (Exp a)) signum = lift1 (signum :: HSL (Exp a) -> HSL (Exp a)) fromInteger i = let f = P.fromInteger i :: Exp a - in lift $ HSL f f f + in lift $ HSL f f f -instance {-# OVERLAPS #-} A.Fractional a => P.Fractional (Exp (HSL a)) where +instance (A.Fractional a, Unlift Exp (HSL (Exp a)), Plain (HSL (Exp a)) ~ HSL a) + => P.Fractional (Exp (HSL a)) where (/) = lift2 ((/) :: HSL (Exp a) -> HSL (Exp a) -> HSL (Exp a)) recip = lift1 (recip :: HSL (Exp a) -> HSL (Exp a)) fromRational r = let f = P.fromRational r :: Exp a - in lift $ HSL f f f + in lift $ HSL f f f -- Named colours diff --git a/Data/Array/Accelerate/Data/Colour/HSV.hs b/Data/Array/Accelerate/Data/Colour/HSV.hs --- a/Data/Array/Accelerate/Data/Colour/HSV.hs +++ b/Data/Array/Accelerate/Data/Colour/HSV.hs @@ -1,24 +1,24 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif -- | -- Module : Data.Array.Accelerate.Data.Colour.HSV --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -32,6 +32,7 @@ Colour, HSV(..), + pattern HSV_, hsv, clamp, @@ -43,16 +44,14 @@ ) where import Data.Array.Accelerate as A hiding ( clamp ) -import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Product ( TupleIdx(..), IsProduct(..) ) -import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..) ) +import Data.Array.Accelerate.Sugar.Elt +import Data.Primitive.Vec -import Data.Array.Accelerate.Data.Colour.RGB ( RGB(..) ) +import Data.Array.Accelerate.Data.Colour.RGB ( RGB(..), pattern RGB_ ) import Data.Array.Accelerate.Data.Colour.Names as C import Data.Functor import Data.Typeable -import Prelude ( fromInteger ) -- ghc < 8 bug import qualified Prelude as P @@ -70,13 +69,12 @@ -> Exp Colour hsv h s v = clamp - $ lift (HSV h s v) + $ HSV_ h s v clamp :: Exp Colour -> Exp Colour -clamp (unlift -> HSV h s v) - = lift - $ HSV (fmod h 360) (c s) (c v) +clamp (HSV_ h s v) + = HSV_ (fmod h 360) (c s) (c v) where c x = 0 `max` x `min` 1 @@ -88,7 +86,7 @@ -- | Convert a HSV colour to an RGB colour-space value -- toRGB :: Exp (HSV Float) -> Exp (RGB Float) -toRGB (unlift -> HSV h s v) = rgb +toRGB (HSV_ h s v) = rgb where c = v * s h' = h / 60 @@ -98,18 +96,18 @@ c' = c + m x' = x + m -- - rgb = h' < 1 ? ( lift (RGB c' x' m) - , h' < 2 ? ( lift (RGB x' c' m) - , h' < 3 ? ( lift (RGB m c' x') - , h' < 4 ? ( lift (RGB m x' c') - , h' < 5 ? ( lift (RGB x' m c') - , ( lift (RGB c' m x') )))))) + rgb = h' < 1 ? ( RGB_ c' x' m + , h' < 2 ? ( RGB_ x' c' m + , h' < 3 ? ( RGB_ m c' x' + , h' < 4 ? ( RGB_ m x' c' + , h' < 5 ? ( RGB_ x' m c' + , ( RGB_ c' m x' )))))) -- | Convert a point in the RGB colour-space to a point in the HSV colour-space. -- fromRGB :: Exp (RGB Float) -> Exp (HSV Float) -fromRGB (unlift -> RGB r g b) = lift (HSV h s v) +fromRGB (RGB_ r g b) = HSV_ h s v where mx = P.maximum [r,g,b] mn = P.minimum [r,g,b] @@ -128,17 +126,23 @@ -- | Return the HSV-hue of an RGB colour -- hue :: Exp (RGB Float) -> Exp Float -hue (unlift . fromRGB -> HSV h _ _) = h +hue c = + let HSV_ h _ _ = fromRGB c + in h -- | Return the HSV-saturation of an RGB colour -- saturation :: Exp (RGB Float) -> Exp Float -saturation (unlift . fromRGB -> HSV _ s _) = s +saturation c = + let HSV_ _ s _ = fromRGB c + in s -- | Return the HSV-value of an RGB colour -- value :: Exp (RGB Float) -> Exp Float -value (unlift . fromRGB -> HSV _ _ v) = v +value c = + let HSV_ _ _ v = fromRGB c + in v -- Accelerate bits @@ -147,32 +151,29 @@ -- HSV colour space -- data HSV a = HSV a a a - deriving (P.Show, P.Eq, Functor, Typeable) + deriving (P.Show, P.Eq, Functor, Typeable, Generic) --- Represent colours in Accelerate as a 3-tuple --- -type instance EltRepr (HSV a) = EltRepr (a, a, a) +pattern HSV_ :: (Elt (HSV a), Elt a, VecElt a, EltR (HSV a) ~ Vec3 a) => Exp a -> Exp a -> Exp a -> Exp (HSV a) +pattern HSV_ h s v = V3 h s v +{-# COMPLETE HSV_ #-} -instance Elt a => Elt (HSV a) where - eltType (_ :: HSV a) = eltType (undefined :: (a,a,a)) - toElt c = let (h,s,v) = toElt c in HSV h s v - fromElt (HSV h s v) = fromElt (h,s,v) +instance Elt (HSV Float) where + type EltR (HSV Float) = Vec3 Float + eltR = eltR @(Vec3 Float) + tagsR = tagsR @(Vec3 Float) + toElt (Vec3 r g b) = HSV r g b + fromElt (HSV r g b) = Vec3 r g b -instance Elt a => IsProduct Elt (HSV a) where - type ProdRepr (HSV a) = ((((),a), a), a) - fromProd _ (HSV h s v) = ((((), h), s), v) - toProd _ ((((),h),s),v) = HSV h s v - prod cst _ = prod cst (undefined :: (a,a,a)) +instance Lift Exp (HSV Float) where + type Plain (HSV Float) = HSV Float + lift = constant -instance (Lift Exp a, Elt (Plain a)) => Lift Exp (HSV a) where - type Plain (HSV a) = HSV (Plain a) - lift (HSV h s v) = Exp . Tuple $ NilTup `SnocTup` lift h `SnocTup` lift s `SnocTup` lift v +instance Lift Exp (HSV (Exp Float)) where + type Plain (HSV (Exp Float)) = HSV Float + lift (HSV h s v) = HSV_ h s v -instance Elt a => Unlift Exp (HSV (Exp a)) where - unlift c = let h = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` c - s = Exp $ SuccTupIdx ZeroTupIdx `Prj` c - v = Exp $ ZeroTupIdx `Prj` c - in HSV h s v +instance Unlift Exp (HSV (Exp Float)) where + unlift (HSV_ h s v) = HSV h s v instance P.Num a => P.Num (HSV a) where (+) (HSV h1 s1 v1 ) (HSV h2 s2 v2) @@ -192,7 +193,7 @@ fromInteger i = let f = P.fromInteger i - in HSV f f f + in HSV f f f instance (P.Num a, P.Fractional a) => P.Fractional (HSV a) where (/) (HSV h1 s1 v1) (HSV h2 s2 v2) @@ -203,23 +204,25 @@ fromRational r = let f = P.fromRational r - in HSV f f f + in HSV f f f -instance {-# OVERLAPS #-} A.Num a => P.Num (Exp (HSV a)) where +instance (A.Num a, Unlift Exp (HSV (Exp a)), Plain (HSV (Exp a)) ~ HSV a) + => P.Num (Exp (HSV a)) where (+) = lift2 ((+) :: HSV (Exp a) -> HSV (Exp a) -> HSV (Exp a)) (-) = lift2 ((-) :: HSV (Exp a) -> HSV (Exp a) -> HSV (Exp a)) (*) = lift2 ((*) :: HSV (Exp a) -> HSV (Exp a) -> HSV (Exp a)) abs = lift1 (abs :: HSV (Exp a) -> HSV (Exp a)) signum = lift1 (signum :: HSV (Exp a) -> HSV (Exp a)) fromInteger i = let f = P.fromInteger i :: Exp a - in lift $ HSV f f f + in lift $ HSV f f f -instance {-# OVERLAPS #-} A.Fractional a => P.Fractional (Exp (HSV a)) where +instance (A.Fractional a, Unlift Exp (HSV (Exp a)), Plain (HSV (Exp a)) ~ HSV a) + => P.Fractional (Exp (HSV a)) where (/) = lift2 ((/) :: HSV (Exp a) -> HSV (Exp a) -> HSV (Exp a)) recip = lift1 (recip :: HSV (Exp a) -> HSV (Exp a)) fromRational r = let f = P.fromRational r :: Exp a - in lift $ HSV f f f + in lift $ HSV f f f -- Named colours diff --git a/Data/Array/Accelerate/Data/Colour/Internal/Pack.hs b/Data/Array/Accelerate/Data/Colour/Internal/Pack.hs --- a/Data/Array/Accelerate/Data/Colour/Internal/Pack.hs +++ b/Data/Array/Accelerate/Data/Colour/Internal/Pack.hs @@ -1,9 +1,9 @@ -- | -- Module : Data.Array.Accelerate.Data.Colour.Internal.Pack --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/Data/Array/Accelerate/Data/Colour/Names.hs b/Data/Array/Accelerate/Data/Colour/Names.hs --- a/Data/Array/Accelerate/Data/Colour/Names.hs +++ b/Data/Array/Accelerate/Data/Colour/Names.hs @@ -1,10 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : Data.Array.Accelerate.Data.Colour.Names --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/Data/Array/Accelerate/Data/Colour/RGB.hs b/Data/Array/Accelerate/Data/Colour/RGB.hs --- a/Data/Array/Accelerate/Data/Colour/RGB.hs +++ b/Data/Array/Accelerate/Data/Colour/RGB.hs @@ -1,24 +1,24 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif -- | -- Module : Data.Array.Accelerate.Data.Colour.RGB --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -29,6 +29,7 @@ Colour, RGB(..), + pattern RGB_, rgb, rgb8, clamp, @@ -41,13 +42,11 @@ ) where import Data.Array.Accelerate as A hiding ( clamp ) -import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..) ) -import Data.Array.Accelerate.Product ( TupleIdx(..), IsProduct(..) ) -import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Sugar.Elt +import Data.Primitive.Vec import Data.Array.Accelerate.Data.Colour.Names -import Data.Array.Accelerate.Data.Colour.RGBA ( RGBA(..) ) +import Data.Array.Accelerate.Data.Colour.RGBA ( pattern RGBA_ ) import Data.Array.Accelerate.Data.Colour.Internal.Pack ( word8OfFloat ) import Data.Typeable @@ -67,7 +66,7 @@ -> Exp Colour rgb r g b = clamp - $ lift (RGB r g b) + $ RGB_ r g b -- | Construct a colour from 8-bit-per-channel colour components. @@ -77,10 +76,9 @@ -> Exp Word8 -- ^ blue component -> Exp Colour rgb8 r g b - = lift - $ RGB (A.fromIntegral r / 255 :: Exp Float) - (A.fromIntegral g / 255) - (A.fromIntegral b / 255) + = RGB_ (A.fromIntegral r / 255 :: Exp Float) + (A.fromIntegral g / 255) + (A.fromIntegral b / 255) -- | Clamp each component of a colour to the range [0..1]. @@ -108,11 +106,8 @@ -> Exp Colour -- ^ First colour -> Exp Colour -- ^ Second colour -> Exp Colour -- ^ Resulting colour -blend m1 m2 c1 c2 = +blend m1 m2 (RGB_ r1 g1 b1) (RGB_ r2 g2 b2) = let - RGB r1 g1 b1 = unlift c1 - RGB r2 g2 b2 = unlift c2 - -- Normalise mixing proportions to ratios. m12 = m1 + m2 m1' = m1 / m12 @@ -132,7 +127,7 @@ -- | Luminance of an RGB colour (Y component of a YUV colour). -- luminance :: Exp Colour -> Exp Float -luminance (unlift -> RGB r g b) = 0.299*r + 0.587*g + 0.114*b +luminance (RGB_ r g b) = 0.299*r + 0.587*g + 0.114*b -- Packed representation @@ -141,47 +136,51 @@ -- | Convert a Colour into a packed-word RGBA representation -- packRGB :: Exp Colour -> Exp Word32 -packRGB (unlift -> RGB r g b) +packRGB (RGB_ r g b) = bitcast - . lift - $ RGBA (word8OfFloat r) (word8OfFloat g) (word8OfFloat b) 0xFF + $ RGBA_ (word8OfFloat r) (word8OfFloat g) (word8OfFloat b) 0xFF -- | Convert a colour into a packed-word ABGR representation -- packBGR :: Exp Colour -> Exp Word32 -packBGR (unlift -> RGB r g b) +packBGR (RGB_ r g b) = bitcast - . lift - $ RGBA 0xFF (word8OfFloat b) (word8OfFloat g) (word8OfFloat r) + $ RGBA_ 0xFF (word8OfFloat b) (word8OfFloat g) (word8OfFloat r) packRGB8 :: Exp (RGB Word8) -> Exp Word32 -packRGB8 (unlift -> RGB r g b :: RGB (Exp Word8)) +packRGB8 (RGB_ r g b) = bitcast - . lift - $ RGBA r g b 0xFF + $ RGBA_ r g b 0xFF packBGR8 :: Exp (RGB Word8) -> Exp Word32 -packBGR8 (unlift -> RGB r g b :: RGB (Exp Word8)) +packBGR8 (RGB_ r g b) = bitcast - . lift - $ RGBA 0xff b g r + $ RGBA_ 0xff b g r -- | Convert a colour from a packed-word RGBA representation -- unpackRGB :: Exp Word32 -> Exp Colour -unpackRGB (unlift . bitcast -> RGBA r g b _ :: RGBA (Exp Word8)) = rgb8 r g b +unpackRGB w = + let RGBA_ r g b _ = bitcast w + in rgb8 r g b -- | Convert a colour from a packed-word ABGR representation -- unpackBGR :: Exp Word32 -> Exp Colour -unpackBGR (unlift . bitcast -> RGBA _ b g r :: RGBA (Exp Word8)) = rgb8 r g b +unpackBGR w = + let RGBA_ _ b g r = bitcast w + in rgb8 r g b unpackRGB8 :: Exp Word32 -> Exp (RGB Word8) -unpackRGB8 (unlift . bitcast -> RGBA r g b _ :: RGBA (Exp Word8)) = lift (RGB r g b) +unpackRGB8 w = + let RGBA_ r g b _ = bitcast w + in RGB_ r g b unpackBGR8 :: Exp Word32 -> Exp (RGB Word8) -unpackBGR8 (unlift . bitcast -> RGBA _ b g r :: RGBA (Exp Word8)) = lift (RGB r g b) +unpackBGR8 w = + let RGBA_ _ b g r = bitcast w + in RGB_ r g b -- Accelerate bits @@ -196,32 +195,25 @@ -- when exporting the data (e.g. as a 24-bit BMP image). -- data RGB a = RGB a a a - deriving (Show, P.Eq, Functor, Typeable) + deriving (Show, P.Eq, Functor, Typeable, Generic) -type instance EltRepr (RGB Float) = EltRepr (Float, Float, Float) -type instance EltRepr (RGB Word8) = V3 Word8 +pattern RGB_ :: (Elt (RGB a), Elt a, VecElt a, EltR (RGB a) ~ Vec3 a) => Exp a -> Exp a -> Exp a -> Exp (RGB a) +pattern RGB_ r g b = V3 r g b +{-# COMPLETE RGB_ #-} instance Elt (RGB Float) where - eltType _ = eltType (undefined::(Float,Float,Float)) - toElt t = let (r,g,b) = toElt t in RGB r g b - fromElt (RGB r g b) = fromElt (r,g,b) + type EltR (RGB Float) = Vec3 Float + eltR = eltR @(Vec3 Float) + tagsR = tagsR @(Vec3 Float) + toElt (Vec3 r g b) = RGB r g b + fromElt (RGB r g b) = Vec3 r g b instance Elt (RGB Word8) where - eltType _ = TypeRscalar scalarType - toElt (V3 r g b) = RGB r g b - fromElt (RGB r g b) = V3 r g b - -instance IsProduct Elt (RGB Float) where - type ProdRepr (RGB Float) = ProdRepr (Float,Float,Float) - fromProd cst (RGB r g b) = fromProd cst (r,g,b) - toProd cst p = let (r,g,b) = toProd cst p in RGB r g b - prod cst _ = prod cst (undefined :: (Float,Float,Float)) - -instance IsProduct Elt (RGB Word8) where - type ProdRepr (RGB Word8) = ProdRepr (V3 Word8) - fromProd cst (RGB r g b) = fromProd cst (V3 r g b) - toProd cst p = let V3 r g b = toProd cst p in RGB r g b - prod cst _ = prod cst (undefined :: V3 Word8) + type EltR (RGB Word8) = Vec3 Word8 + eltR = eltR @(Vec3 Word8) + tagsR = tagsR @(Vec3 Word8) + toElt (Vec3 r g b) = RGB r g b + fromElt (RGB r g b) = Vec3 r g b instance Lift Exp (RGB Float) where type Plain (RGB Float) = RGB Float @@ -233,28 +225,17 @@ instance Lift Exp (RGB (Exp Float)) where type Plain (RGB (Exp Float)) = RGB Float - lift (RGB r g b) = Exp . Tuple $ NilTup `SnocTup` r `SnocTup` g `SnocTup` b + lift (RGB r g b) = RGB_ r g b instance Lift Exp (RGB (Exp Word8)) where type Plain (RGB (Exp Word8)) = RGB Word8 - lift (RGB r g b) = Exp . Tuple $ NilTup `SnocTup` r `SnocTup` g `SnocTup` b + lift (RGB r g b) = RGB_ r g b instance Unlift Exp (RGB (Exp Float)) where - unlift c = - let - r = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` c - g = Exp $ SuccTupIdx ZeroTupIdx `Prj` c - b = Exp $ ZeroTupIdx `Prj` c - in - RGB r g b + unlift (RGB_ r g b) = RGB r g b instance Unlift Exp (RGB (Exp Word8)) where - unlift c = - let r = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` c - g = Exp $ SuccTupIdx ZeroTupIdx `Prj` c - b = Exp $ ZeroTupIdx `Prj` c - in - RGB r g b + unlift (RGB_ r g b) = RGB r g b instance P.Num a => P.Num (RGB a) where @@ -275,7 +256,7 @@ fromInteger i = let f = P.fromInteger i - in RGB f f f + in RGB f f f instance (P.Num a, P.Fractional a) => P.Fractional (RGB a) where (/) (RGB r1 g1 b1) (RGB r2 g2 b2) @@ -286,7 +267,7 @@ fromRational r = let f = P.fromRational r - in RGB f f f + in RGB f f f instance (A.Num a, Unlift Exp (RGB (Exp a)), Plain (RGB (Exp a)) ~ RGB a) => P.Num (Exp (RGB a)) where @@ -296,14 +277,14 @@ abs = lift1 (abs :: RGB (Exp a) -> RGB (Exp a)) signum = lift1 (signum :: RGB (Exp a) -> RGB (Exp a)) fromInteger i = let f = P.fromInteger i :: Exp a - in lift $ RGB f f f + in lift $ RGB f f f instance (A.Fractional a, Unlift Exp (RGB (Exp a)), Plain (RGB (Exp a)) ~ RGB a) => P.Fractional (Exp (RGB a)) where (/) = lift2 ((/) :: RGB (Exp a) -> RGB (Exp a) -> RGB (Exp a)) recip = lift1 (recip :: RGB (Exp a) -> RGB (Exp a)) fromRational r = let f = P.fromRational r :: Exp a - in lift $ RGB f f f + in lift $ RGB f f f -- Named colours diff --git a/Data/Array/Accelerate/Data/Colour/RGBA.hs b/Data/Array/Accelerate/Data/Colour/RGBA.hs --- a/Data/Array/Accelerate/Data/Colour/RGBA.hs +++ b/Data/Array/Accelerate/Data/Colour/RGBA.hs @@ -1,24 +1,24 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -#if __GLASGOW_HASKELL__ <= 708 -{-# LANGUAGE OverlappingInstances #-} -{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} -#endif -- | -- Module : Data.Array.Accelerate.Data.Colour.RGBA --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -29,6 +29,7 @@ Colour, RGBA(..), + pattern RGBA_, rgba, rgba8, clamp, @@ -42,10 +43,8 @@ ) where import Data.Array.Accelerate as A hiding ( clamp ) -import Data.Array.Accelerate.Array.Sugar ( Elt(..), EltRepr, Tuple(..) ) -import Data.Array.Accelerate.Product ( TupleIdx(..), IsProduct(..) ) -import Data.Array.Accelerate.Smart -import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Sugar.Elt +import Data.Primitive.Vec import Data.Array.Accelerate.Data.Colour.Names import Data.Array.Accelerate.Data.Colour.Internal.Pack ( word8OfFloat ) @@ -70,7 +69,7 @@ -> Exp Colour rgba r g b a = clamp - $ lift (RGBA r g b a) + $ RGBA_ r g b a -- | Construct a colour from 8-bits-per-channel colour components. @@ -82,11 +81,10 @@ -> Exp Word8 -- ^ alpha component -> Exp Colour rgba8 r g b a - = lift - $ RGBA (A.fromIntegral r / 255 :: Exp Float) - (A.fromIntegral g / 255) - (A.fromIntegral b / 255) - (A.fromIntegral a / 255) + = RGBA_ (A.fromIntegral r / 255 :: Exp Float) + (A.fromIntegral g / 255) + (A.fromIntegral b / 255) + (A.fromIntegral a / 255) -- | Clamp each component to the range [0..1] @@ -114,11 +112,8 @@ -> Exp Colour -- ^ First colour -> Exp Colour -- ^ Second colour -> Exp Colour -- ^ Resulting colour -blend m1 m2 c1 c2 = +blend m1 m2 (RGBA_ r1 g1 b1 a1) (RGBA_ r2 g2 b2 a2) = let - RGBA r1 g1 b1 a1 = unlift c1 - RGBA r2 g2 b2 a2 = unlift c2 - -- Normalise mixing proportions to ratios. m12 = m1 + m2 m1' = m1 / m12 @@ -139,14 +134,14 @@ -- | Luminance of an RGB colour (Y component of a YUV colour). -- luminance :: Exp Colour -> Exp Float -luminance (unlift -> RGBA r g b _) = 0.299*r + 0.587*g + 0.114*b +luminance (RGBA_ r g b _) = 0.299*r + 0.587*g + 0.114*b -- | Set the opacity of the given colour. The opacity is clamped to the range -- [0..1]. -- opacity :: Exp Float -> Exp Colour -> Exp Colour -opacity a (unlift -> RGBA r g b _) = lift $ RGBA r g b (0 `A.max` a `A.min` 1) +opacity a (RGBA_ r g b _) = RGBA_ r g b (0 `A.max` a `A.min` 1) -- | Make colour transparent -- @@ -165,44 +160,47 @@ -- | Convert a Colour into a packed-word RGBA representation -- packRGBA :: Exp Colour -> Exp Word32 -packRGBA (unlift -> RGBA r g b a) +packRGBA (RGBA_ r g b a) = bitcast - . lift - $ RGBA (word8OfFloat r) (word8OfFloat g) (word8OfFloat b) (word8OfFloat a) + $ RGBA_ (word8OfFloat r) (word8OfFloat g) (word8OfFloat b) (word8OfFloat a) -- | Convert a colour into a packed-word ABGR representation -- packABGR :: Exp Colour -> Exp Word32 -packABGR (unlift -> RGBA r g b a) +packABGR (RGBA_ r g b a) = bitcast - . lift - $ RGBA (word8OfFloat a) (word8OfFloat b) (word8OfFloat g) (word8OfFloat r) + $ RGBA_ (word8OfFloat a) (word8OfFloat b) (word8OfFloat g) (word8OfFloat r) packRGBA8 :: Exp (RGBA Word8) -> Exp Word32 packRGBA8 = bitcast packABGR8 :: Exp (RGBA Word8) -> Exp Word32 -packABGR8 (unlift -> RGBA r g b a :: RGBA (Exp Word8)) +packABGR8 (RGBA_ r g b a) = bitcast - $ lift (RGBA a b g r) + $ RGBA_ a b g r -- | Convert a colour from a packed-word RGBA representation -- unpackRGBA :: Exp Word32 -> Exp Colour -unpackRGBA (unlift . bitcast -> RGBA r g b a) = rgba8 r g b a +unpackRGBA w = + let RGBA_ r g b a = bitcast w + in rgba8 r g b a -- | Convert a colour from a packed-word ABGR representation -- unpackABGR :: Exp Word32 -> Exp Colour -unpackABGR (unlift . bitcast -> RGBA a b g r) = rgba8 r g b a +unpackABGR w = + let RGBA_ a b g r = bitcast w + in rgba8 r g b a unpackRGBA8 :: Exp Word32 -> Exp (RGBA Word8) unpackRGBA8 = bitcast unpackABGR8 :: Exp Word32 -> Exp (RGBA Word8) -unpackABGR8 (unlift . bitcast -> RGBA a b g r :: RGBA (Exp Word8)) = - lift (RGBA r g b a) +unpackABGR8 w = + let RGBA_ a b g r = bitcast w + in RGBA_ r g b a -- Accelerate bits @@ -217,32 +215,25 @@ -- when exporting the data (e.g. as a 32-bit BMP image) -- data RGBA a = RGBA a a a a - deriving (Show, P.Eq, Functor, Typeable) + deriving (Show, P.Eq, Functor, Typeable, Generic) -type instance EltRepr (RGBA Float) = EltRepr (Float,Float,Float,Float) -type instance EltRepr (RGBA Word8) = V4 Word8 +pattern RGBA_ :: (Elt (RGBA a), Elt a, VecElt a, EltR (RGBA a) ~ Vec4 a) => Exp a -> Exp a -> Exp a -> Exp a -> Exp (RGBA a) +pattern RGBA_ r g b a = V4 r g b a +{-# COMPLETE RGBA_ #-} instance Elt (RGBA Float) where - eltType _ = eltType (undefined::(Float,Float,Float,Float)) - toElt t = let (r,g,b,a) = toElt t in RGBA r g b a - fromElt (RGBA r g b a) = fromElt (r,g,b,a) + type EltR (RGBA Float) = Vec4 Float + eltR = eltR @(Vec4 Float) + tagsR = tagsR @(Vec4 Float) + toElt (Vec4 r g b a) = RGBA r g b a + fromElt (RGBA r g b a) = Vec4 r g b a instance Elt (RGBA Word8) where - eltType _ = TypeRscalar scalarType - toElt (V4 r g b a) = RGBA r g b a - fromElt (RGBA r g b a) = V4 r g b a - -instance IsProduct Elt (RGBA Float) where - type ProdRepr (RGBA Float) = ProdRepr (Float,Float,Float,Float) - fromProd cst (RGBA r g b a) = fromProd cst (r,g,b,a) - toProd cst p = let (r,g,b,a) = toProd cst p in RGBA r g b a - prod cst _ = prod cst (undefined :: (Float,Float,Float,Float)) - -instance IsProduct Elt (RGBA Word8) where - type ProdRepr (RGBA Word8) = ProdRepr (V4 Word8) - fromProd cst (RGBA r g b a) = fromProd cst (V4 r g b a) - toProd cst p = let V4 r g b a = toProd cst p in RGBA r g b a - prod cst _ = prod cst (undefined :: V4 Word8) + type EltR (RGBA Word8) = Vec4 Word8 + eltR = eltR @(Vec4 Word8) + tagsR = tagsR @(Vec4 Word8) + toElt (Vec4 r g b a) = RGBA r g b a + fromElt (RGBA r g b a) = Vec4 r g b a instance Lift Exp (RGBA Float) where type Plain (RGBA Float) = RGBA Float @@ -254,29 +245,17 @@ instance Lift Exp (RGBA (Exp Float)) where type Plain (RGBA (Exp Float)) = RGBA Float - lift (RGBA r g b a) = Exp . Tuple $ NilTup `SnocTup` r `SnocTup` g `SnocTup` b `SnocTup` a + lift (RGBA r g b a) = RGBA_ r g b a instance Lift Exp (RGBA (Exp Word8)) where type Plain (RGBA (Exp Word8)) = RGBA Word8 - lift (RGBA r g b a) = Exp . Tuple $ NilTup `SnocTup` r `SnocTup` g `SnocTup` b `SnocTup` a + lift (RGBA r g b a) = RGBA_ r g b a instance Unlift Exp (RGBA (Exp Float)) where - unlift c = - let r = Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` c - g = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` c - b = Exp $ SuccTupIdx ZeroTupIdx `Prj` c - a = Exp $ ZeroTupIdx `Prj` c - in - RGBA r g b a + unlift (RGBA_ r g b a) = RGBA r g b a instance Unlift Exp (RGBA (Exp Word8)) where - unlift c = - let r = Exp $ SuccTupIdx (SuccTupIdx (SuccTupIdx ZeroTupIdx)) `Prj` c - g = Exp $ SuccTupIdx (SuccTupIdx ZeroTupIdx) `Prj` c - b = Exp $ SuccTupIdx ZeroTupIdx `Prj` c - a = Exp $ ZeroTupIdx `Prj` c - in - RGBA r g b a + unlift (RGBA_ r g b a) = RGBA r g b a instance P.Num a => P.Num (RGBA a) where @@ -297,7 +276,7 @@ fromInteger i = let f = P.fromInteger i - in RGBA f f f 1 + in RGBA f f f 1 instance (P.Num a, P.Fractional a) => P.Fractional (RGBA a) where (/) (RGBA r1 g1 b1 _) (RGBA r2 g2 b2 _) @@ -308,7 +287,7 @@ fromRational r = let f = P.fromRational r - in RGBA f f f 1 + in RGBA f f f 1 instance (A.Num a, Unlift Exp (RGBA (Exp a)), Plain (RGBA (Exp a)) ~ RGBA a) => P.Num (Exp (RGBA a)) where @@ -319,7 +298,7 @@ signum = lift1 (signum :: RGBA (Exp a) -> RGBA (Exp a)) fromInteger i = let f = P.fromInteger i a = P.fromInteger 1 :: Exp a - in lift $ RGBA f f f a + in lift $ RGBA f f f a instance (A.Fractional a, Unlift Exp (RGBA (Exp a)), Plain (RGBA (Exp a)) ~ RGBA a) => P.Fractional (Exp (RGBA a)) where @@ -327,7 +306,7 @@ recip = lift1 (recip :: RGBA (Exp a) -> RGBA (Exp a)) fromRational r = let f = P.fromRational r a = P.fromRational 1 :: Exp a - in lift $ RGBA f f f a + in lift $ RGBA f f f a -- Named colours diff --git a/Data/Array/Accelerate/Data/Colour/SRGB.hs b/Data/Array/Accelerate/Data/Colour/SRGB.hs --- a/Data/Array/Accelerate/Data/Colour/SRGB.hs +++ b/Data/Array/Accelerate/Data/Colour/SRGB.hs @@ -1,13 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Data.Colour.SRGB --- Copyright : [2016] Trevor L. McDonell +-- Copyright : [2016..2020] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -24,7 +25,7 @@ ) where import Data.Array.Accelerate as A hiding ( clamp ) -import Data.Array.Accelerate.Data.Colour.RGB ( RGB(..) ) +import Data.Array.Accelerate.Data.Colour.RGB ( RGB(..), pattern RGB_ ) import Data.Functor ( fmap ) @@ -46,7 +47,7 @@ -> Exp Colour srgb r g b = clamp - $ lift (RGB r g b) + $ RGB_ r g b -- | Construct an sRGB colour from 8-bit-per-channel colour components. @@ -56,10 +57,9 @@ -> Exp Word8 -- ^ blue component -> Exp Colour srgb8 r g b - = lift - $ RGB (fromIntegral r / 255 :: Exp Float) - (fromIntegral g / 255) - (fromIntegral b / 255) + = RGB_ (fromIntegral r / 255 :: Exp Float) + (fromIntegral g / 255) + (fromIntegral b / 255) -- | Clamp each component of a colour to the range [0..1]. @@ -74,21 +74,19 @@ -- colour space. -- fromRGB :: Exp (RGB Float) -> Exp (SRGB Float) -fromRGB (unlift -> RGB r g b) - = lift - $ RGB (invTransferFunction r) - (invTransferFunction g) - (invTransferFunction b) +fromRGB (RGB_ r g b) + = RGB_ (invTransferFunction r) + (invTransferFunction g) + (invTransferFunction b) -- | Convert a colour in the linear sRGB colour space into the non-linear RGB -- colour space. -- toRGB :: Exp (SRGB Float) -> Exp (RGB Float) -toRGB (unlift -> RGB r g b) - = lift - $ RGB (transferFunction r) - (transferFunction g) - (transferFunction b) +toRGB (RGB_ r g b) + = RGB_ (transferFunction r) + (transferFunction g) + (transferFunction b) -- The non-linear sRGB transfer function approximates a gamma of about 2.2. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2016, Trevor L. McDonell +Copyright (c) [2016..2020], Trevor L. McDonell All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,16 +1,25 @@ -colour-accelerate -================= +
+henlo, my name is Theia -[![Build Status](https://travis-ci.org/tmcdonell/colour-accelerate.svg?branch=master)](https://travis-ci.org/tmcdonell/colour-accelerate) +# colour-accelerate + +[![GitHub CI](https://github.com/tmcdonell/colour-accelerate/workflows/CI/badge.svg)](https://github.com/tmcdonell/colour-accelerate/actions) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +
[![Stackage LTS](https://stackage.org/package/colour-accelerate/badge/lts)](https://stackage.org/lts/package/colour-accelerate) [![Stackage Nightly](https://stackage.org/package/colour-accelerate/badge/nightly)](https://stackage.org/nightly/package/colour-accelerate) [![Hackage](https://img.shields.io/hackage/v/colour-accelerate.svg)](https://hackage.haskell.org/package/colour-accelerate) +
+ This package provides data types and operations for dealing with colours in Accelerate. For details on Accelerate, refer to the [main -repository](https://github.com/AccelerateHS/accelerate). +repository][accelerate]. +Contributions and bug reports are welcome!
+Please feel free to contact me through [GitHub][accelerate] or [gitter.im][gitter.im]. + Example: Blur ------------- @@ -38,3 +47,6 @@ [blocks]: https://github.com/tmcdonell/colour-accelerate/raw/master/samples/blocks.bmp [blur_srgb]: https://github.com/tmcdonell/colour-accelerate/raw/master/samples/blur_srgb.bmp [blur_rgb]: https://github.com/tmcdonell/colour-accelerate/raw/master/samples/blur_rgb.bmp +[accelerate]: https://github.com/AccelerateHS/accelerate +[gitter.im]: https://gitter.im/AccelerateHS/Lobby + diff --git a/colour-accelerate.cabal b/colour-accelerate.cabal --- a/colour-accelerate.cabal +++ b/colour-accelerate.cabal @@ -1,5 +1,5 @@ name: colour-accelerate -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Working with colours in Accelerate description: This package provides data types for colours and transparency for use with @@ -9,11 +9,10 @@ license: BSD3 license-file: LICENSE author: Trevor L. McDonell -maintainer: Trevor L. McDonell -copyright: Copyright (c) [2016]. Trevor L. McDonell -category: Data, Graphics +maintainer: Trevor L. McDonell +category: Accelerate, Data, Graphics build-type: Simple -cabal-version: >=1.18 +cabal-version: 1.18 homepage: https://github.com/tmcdonell/colour-accelerate bug-reports: https://github.com/tmcdonell/colour-accelerate/issues @@ -30,8 +29,8 @@ library default-language: Haskell2010 build-depends: - base >= 4.7 && < 4.12 - , accelerate >= 1.2 + base >= 4.8 && < 5 + , accelerate >= 1.3 ghc-options: -Wall @@ -54,8 +53,7 @@ source-repository this type: git - tag: 0.3.0.0 + tag: v0.4.0.0 location: https://github.com/tmcdonell/colour-accelerate -- vim: nospell -