From 31ee61d226a05073f519b397d813af2b29cd0275 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 4 Nov 2020 03:15:51 +0300 Subject: [PATCH 01/11] Implementation of: `toGrayscale`, `applyGrayscale` and `replaceGrayscale` --- Color/CHANGELOG.md | 4 + Color/Color.cabal | 15 +++- Color/bench/YCbCr.hs | 71 ++++++++++++++++ Color/src/Graphics/Color/Model/HSI.hs | 2 +- Color/src/Graphics/Color/Model/HSL.hs | 2 +- Color/src/Graphics/Color/Model/HSV.hs | 2 +- Color/src/Graphics/Color/Space/CIE1931/RGB.hs | 6 +- Color/src/Graphics/Color/Space/CIE1976/LAB.hs | 4 + Color/src/Graphics/Color/Space/Internal.hs | 80 ++++++++++++++++--- .../src/Graphics/Color/Space/RGB/AdobeRGB.hs | 8 ++ .../Color/Space/RGB/Alternative/CMYK.hs | 32 ++++++++ .../Color/Space/RGB/Alternative/HSI.hs | 13 ++- .../Color/Space/RGB/Alternative/HSL.hs | 13 ++- .../Color/Space/RGB/Alternative/HSV.hs | 13 ++- .../Color/Space/RGB/Alternative/YCbCr.hs | 35 +++++--- .../Color/Space/RGB/Derived/AdobeRGB.hs | 8 ++ .../Color/Space/RGB/Derived/CIERGB.hs | 4 + .../Graphics/Color/Space/RGB/Derived/SRGB.hs | 11 ++- .../Graphics/Color/Space/RGB/ITU/Rec470.hs | 17 ++++ .../Graphics/Color/Space/RGB/ITU/Rec601.hs | 65 +++++++++++++++ .../Graphics/Color/Space/RGB/ITU/Rec709.hs | 8 ++ .../src/Graphics/Color/Space/RGB/Internal.hs | 42 ++++++++++ Color/src/Graphics/Color/Space/RGB/Luma.hs | 7 ++ Color/src/Graphics/Color/Space/RGB/SRGB.hs | 10 +++ Color/tests/Graphics/Color/Space/Common.hs | 57 ++++++++++++- 25 files changed, 488 insertions(+), 41 deletions(-) create mode 100644 Color/bench/YCbCr.hs diff --git a/Color/CHANGELOG.md b/Color/CHANGELOG.md index a66c10e..a0fdc55 100644 --- a/Color/CHANGELOG.md +++ b/Color/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for Color +## 0.3.4 + +* Addition of: `toGrayscale`, `applyGrayscale` and `replaceGrayscale`. + ## 0.3.3 Addition of `SVG` colors diff --git a/Color/Color.cabal b/Color/Color.cabal index fb12d4f..8504e9e 100644 --- a/Color/Color.cabal +++ b/Color/Color.cabal @@ -1,5 +1,5 @@ name: Color -version: 0.3.3 +version: 0.3.4 synopsis: Color spaces and conversions between them description: Please see the README on GitHub at homepage: https://github.com/lehins/Color @@ -194,6 +194,19 @@ benchmark conversion , random default-language: Haskell2010 +benchmark ycbcr + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: YCbCr.hs + ghc-options: -Wall + -threaded + -O2 + build-depends: base + , criterion + , Color + , deepseq + default-language: Haskell2010 + source-repository head type: git location: https://github.com/lehins/Color diff --git a/Color/bench/YCbCr.hs b/Color/bench/YCbCr.hs new file mode 100644 index 0000000..7c5f0c3 --- /dev/null +++ b/Color/bench/YCbCr.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Criterion.Main +import Control.DeepSeq +import qualified Graphics.Color.Model as CM +import Graphics.Color.Space +import Graphics.Color.Space.RGB.ITU.Rec601 +import Graphics.Color.Space.RGB.ITU.Rec709 +import Data.Coerce + +main :: IO () +main = do + defaultMain + [ bgroup + "toYCbCr" + [ toYCbCrBench (CM.ColorRGB 0.1 0.2 0.3 :: Color CM.RGB Float) "Float" + , toYCbCrBench (CM.ColorRGB 0.1 0.2 0.3 :: Color CM.RGB Double) "Double" + ] + , bgroup + "fromYCbCr" + [ fromYCbCrBench (CM.ColorYCbCr 0.1 0.2 0.3 :: Color CM.YCbCr Float) "Float" + , fromYCbCrBench (CM.ColorYCbCr 0.1 0.2 0.3 :: Color CM.YCbCr Double) "Double" + ] + ] + + +toYCbCrBench :: + forall e. (Elevator e, NFData e) + => Color CM.RGB e + -> String + -> Benchmark +toYCbCrBench rgb tyName = + bgroup + tyName + [ bgroup + "Standard" + [ bench "SRGB" $ + nf (fromBaseSpace :: Color (SRGB 'NonLinear) e -> Color (Y'CbCr SRGB) e) (mkColorRGB rgb) + , bench "Rec601" $ + nf + (fromBaseSpace :: Color (BT601_625 'NonLinear) e -> Color (Y'CbCr BT601_625) e) + (mkColorRGB rgb) + , bench "Rec709" $ + nf (fromBaseSpace :: Color (BT709 'NonLinear) e -> Color (Y'CbCr BT709) e) (mkColorRGB rgb) + ] + ] + +fromYCbCrBench :: + forall e. (Elevator e, NFData e) + => Color CM.YCbCr e + -> String + -> Benchmark +fromYCbCrBench ycbcr tyName = + bgroup + tyName + [ bgroup + "Standard" + [ bench "SRGB" $ + nf (toBaseSpace :: Color (Y'CbCr SRGB) e -> Color (SRGB 'NonLinear) e) (coerce ycbcr) + , bench "Rec601" $ + nf + (toBaseSpace :: Color (Y'CbCr BT601_625) e -> Color (BT601_625 'NonLinear) e) + (coerce ycbcr) + , bench "Rec709" $ + nf (toBaseSpace :: Color (Y'CbCr BT709) e -> Color (BT709 'NonLinear) e) (coerce ycbcr) + ] + ] diff --git a/Color/src/Graphics/Color/Model/HSI.hs b/Color/src/Graphics/Color/Model/HSI.hs index 4cac4aa..48f4dad 100644 --- a/Color/src/Graphics/Color/Model/HSI.hs +++ b/Color/src/Graphics/Color/Model/HSI.hs @@ -23,7 +23,7 @@ module Graphics.Color.Model.HSI , pattern ColorHSI , pattern ColorHSIA , pattern ColorH360SI - , Color + , Color(..) , ColorModel(..) , hsi2rgb , rgb2hsi diff --git a/Color/src/Graphics/Color/Model/HSL.hs b/Color/src/Graphics/Color/Model/HSL.hs index 081785a..e441ac2 100644 --- a/Color/src/Graphics/Color/Model/HSL.hs +++ b/Color/src/Graphics/Color/Model/HSL.hs @@ -23,7 +23,7 @@ module Graphics.Color.Model.HSL , pattern ColorHSL , pattern ColorHSLA , pattern ColorH360SL - , Color + , Color(..) , ColorModel(..) , hc2rgb , hsl2rgb diff --git a/Color/src/Graphics/Color/Model/HSV.hs b/Color/src/Graphics/Color/Model/HSV.hs index 4cd2738..90951d3 100644 --- a/Color/src/Graphics/Color/Model/HSV.hs +++ b/Color/src/Graphics/Color/Model/HSV.hs @@ -23,7 +23,7 @@ module Graphics.Color.Model.HSV , pattern ColorHSV , pattern ColorHSVA , pattern ColorH360SV - , Color + , Color(..) , ColorModel(..) , hc2rgb , hsv2rgb diff --git a/Color/src/Graphics/Color/Space/CIE1931/RGB.hs b/Color/src/Graphics/Color/Space/CIE1931/RGB.hs index 0d3a839..2b575e5 100644 --- a/Color/src/Graphics/Color/Space/CIE1931/RGB.hs +++ b/Color/src/Graphics/Color/Space/CIE1931/RGB.hs @@ -74,6 +74,10 @@ instance (Typeable l, Elevator e) => ColorSpace (CIERGB l) 'E e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . castLinearity . fmap toRealFloat {-# INLINE luminance #-} + grayscale = toBaseModel . fmap fromDouble . luminance + {-# INLINE grayscale #-} + applyGrayscale c f = castLinearity (rgbLinearApplyGrayscale (castLinearity c) f) + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat . castLinearity {-# INLINE toColorXYZ #-} fromColorXYZ xyz = castLinearity (fromRealFloat <$> xyz2rgbLinear @CIERGB xyz) @@ -94,4 +98,4 @@ instance RedGreenBlue CIERGB 'E where -- @since 0.2.0 castLinearity :: Color (CIERGB l') e -> Color (CIERGB l) e castLinearity = coerce - +{-# INLINE castLinearity #-} diff --git a/Color/src/Graphics/Color/Space/CIE1976/LAB.hs b/Color/src/Graphics/Color/Space/CIE1976/LAB.hs index da759ec..7f4aa11 100644 --- a/Color/src/Graphics/Color/Space/CIE1976/LAB.hs +++ b/Color/src/Graphics/Color/Space/CIE1976/LAB.hs @@ -91,6 +91,10 @@ instance (Illuminant i, Elevator e, RealFloat e) => ColorSpace (LAB (i :: k)) i {-# INLINE fromBaseSpace #-} luminance (ColorLAB l' _ _) = Y (ift (scaleLightness l')) {-# INLINE luminance #-} + grayscale (ColorLAB l' _ _) = X l' + {-# INLINE grayscale #-} + replaceGrayscale (ColorLAB _ a' b') (X l') = ColorLAB l' a' b' + {-# INLINE replaceGrayscale #-} toColorXYZ = lab2xyz {-# INLINE toColorXYZ #-} fromColorXYZ = xyz2lab diff --git a/Color/src/Graphics/Color/Space/Internal.hs b/Color/src/Graphics/Color/Space/Internal.hs index d311678..a7b127d 100644 --- a/Color/src/Graphics/Color/Space/Internal.hs +++ b/Color/src/Graphics/Color/Space/Internal.hs @@ -50,6 +50,7 @@ module Graphics.Color.Space.Internal , whitePointTristimulus , CCT(..) , Y + , unY , pattern Y , pattern YA , XYZ @@ -61,13 +62,14 @@ module Graphics.Color.Space.Internal , showsColorModel , module Graphics.Color.Algebra.Binary , module Graphics.Color.Algebra.Elevator + , module Graphics.Color.Model.X ) where import Foreign.Storable import Graphics.Color.Algebra.Binary import Graphics.Color.Algebra.Elevator import Graphics.Color.Model.Internal -import qualified Graphics.Color.Model.X as CM +import Graphics.Color.Model.X import Data.Typeable import Data.Coerce import GHC.TypeNats @@ -75,6 +77,7 @@ import Data.Kind class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) => ColorSpace cs (i :: k) e | cs -> i where + {-# MINIMAL toBaseSpace, fromBaseSpace, luminance, grayscale, (replaceGrayscale|applyGrayscale) #-} type BaseModel cs :: Type @@ -96,11 +99,44 @@ class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) => toBaseSpace :: ColorSpace (BaseSpace cs) i e => Color cs e -> Color (BaseSpace cs) e fromBaseSpace :: ColorSpace (BaseSpace cs) i e => Color (BaseSpace cs) e -> Color cs e - -- | Get the relative luminance of a color + -- | Get the relative luminance of a color. This is different from `grayscale` in that + -- it will produce achromatic color that is no longer dependent on the source color -- -- @since 0.1.0 luminance :: (Elevator a, RealFloat a) => Color cs e -> Color (Y i) a + -- | Drop chromatic information and get only the grayscale information from the + -- color. Without knowledge of the source color the produced value is inconsequential. + -- + -- @since 0.3.1 + grayscale :: Color cs e -> Color X e + + -- | Replace the grayscale information, leaving the chromatic portion of the coloer + -- intact. + -- + -- Property that this function must obide: + -- + -- > replaceGrayscale c y = applyGrayscale c (const y) + -- + -- @since 0.3.1 + replaceGrayscale :: Color cs e -> Color X e -> Color cs e + replaceGrayscale c y = applyGrayscale c (const y) + {-# INLINE replaceGrayscale #-} + + -- | Apply a function to the grayscale portion of the color leaving chromaticity + -- intact. The meaning of "grayscale" is very much specific to the color space it is being + -- applied to. + -- + -- Property that this function must obide: + -- + -- > applyGrayscale c f = replaceGrayscale c (f (grayscale c)) + -- + -- @since 0.3.1 + applyGrayscale :: Color cs e -> (Color X e -> Color X e) -> Color cs e + applyGrayscale c f = replaceGrayscale c (f (grayscale c)) + {-# INLINE applyGrayscale #-} + + toColorXYZ :: (Elevator a, RealFloat a) => Color cs e -> Color (XYZ i) a default toColorXYZ :: (ColorSpace (BaseSpace cs) i e, Elevator a, RealFloat a) => Color cs e -> Color (XYZ i) a @@ -132,6 +168,10 @@ instance ( ColorSpace cs i e {-# INLINE fromColorXYZ #-} luminance = luminance . dropAlpha {-# INLINE luminance #-} + grayscale = grayscale . dropAlpha + {-# INLINE grayscale #-} + replaceGrayscale c x = modifyOpaque (`replaceGrayscale` x) c + {-# INLINE replaceGrayscale #-} toBaseSpace = modifyOpaque toBaseSpace {-# INLINE toBaseSpace #-} fromBaseSpace = modifyOpaque fromBaseSpace @@ -340,6 +380,10 @@ instance (Illuminant i, Elevator e) => ColorSpace (XYZ i) i e where fromBaseSpace = id luminance (ColorXYZ _ y _) = Y (toRealFloat y) {-# INLINE luminance #-} + grayscale (ColorXYZ _ y _) = X y + {-# INLINE grayscale #-} + replaceGrayscale (ColorXYZ x _ z) (X y) = ColorXYZ x y z + {-# INLINE replaceGrayscale #-} toColorXYZ (ColorXYZ x y z) = ColorXYZ (toRealFloat x) (toRealFloat y) (toRealFloat z) {-# INLINE toColorXYZ #-} fromColorXYZ (ColorXYZ x y z) = ColorXYZ (fromRealFloat x) (fromRealFloat y) (fromRealFloat z) @@ -405,7 +449,7 @@ instance (Illuminant i, Elevator e) => ColorModel (CIExyY (i :: k)) e where showsColorModelName _ = showsType (Proxy :: Proxy (CIExyY i)) -- | CIE xyY color space -instance (Illuminant i, Elevator e) => ColorSpace (CIExyY (i :: k)) i e where +instance (Illuminant i, RealFloat e, Elevator e) => ColorSpace (CIExyY (i :: k)) i e where type BaseModel (CIExyY i) = CIExyY i toBaseModel = id fromBaseModel = id @@ -413,6 +457,14 @@ instance (Illuminant i, Elevator e) => ColorSpace (CIExyY (i :: k)) i e where fromBaseSpace = id luminance _ = Y 1 {-# INLINE luminance #-} + grayscale _ = X 1 + {-# INLINE grayscale #-} + replaceGrayscale xy y = + fromColorXYZ (replaceGrayscale (toColorXYZ xy) y :: Color (XYZ i) e) + {-# INLINE replaceGrayscale #-} + applyGrayscale xy f = + fromColorXYZ (applyGrayscale (toColorXYZ xy) f :: Color (XYZ i) e) + {-# INLINE applyGrayscale #-} toColorXYZ xy = ColorXYZ (x / y) 1 ((1 - x - y) / y) where ColorCIExy x y = toRealFloat <$> xy {-# INLINE toColorXYZ #-} @@ -423,7 +475,6 @@ instance (Illuminant i, Elevator e) => ColorSpace (CIExyY (i :: k)) i e where {-# INLINE fromColorXYZ #-} - ------------- --- Y --- ------------- @@ -432,16 +483,21 @@ instance (Illuminant i, Elevator e) => ColorSpace (CIExyY (i :: k)) i e where data Y (i :: k) -- | Luminance `Y` -newtype instance Color (Y i) e = Luminance (CM.Color CM.X e) +newtype instance Color (Y i) e = Luminance (Color X e) + +-- | Get the luminance value +unY :: Color (Y i) e -> e +unY = coerce +{-# INLINE unY #-} -- | Constructor for @Y@ with alpha channel. pattern Y :: e -> Color (Y i) e -pattern Y y = Luminance (CM.X y) +pattern Y y = Luminance (X y) {-# COMPLETE Y #-} -- | Constructor for @Y@ with alpha channel. pattern YA :: e -> e -> Color (Alpha (Y i)) e -pattern YA y a = Alpha (Luminance (CM.X y)) a +pattern YA y a = Alpha (Luminance (X y)) a {-# COMPLETE YA #-} -- | `Y` - relative luminance of a color space @@ -475,16 +531,22 @@ instance (Illuminant i, Elevator e) => ColorModel (Y i) e where -- | CIE1931 `XYZ` color space instance (Illuminant i, Elevator e) => ColorSpace (Y i) i e where - type BaseModel (Y i) = CM.X + type BaseModel (Y i) = X toBaseSpace = id fromBaseSpace = id luminance = fmap toRealFloat {-# INLINE luminance #-} + grayscale = coerce + {-# INLINE grayscale #-} + applyGrayscale c f = coerce (f (coerce c)) + {-# INLINE applyGrayscale #-} + replaceGrayscale _ = coerce + {-# INLINE replaceGrayscale #-} toColorXYZ (Y y) = ColorXYZ 0 (toRealFloat y) 0 {-# INLINE toColorXYZ #-} fromColorXYZ (ColorXYZ _ y _) = Y (fromRealFloat y) {-# INLINE fromColorXYZ #-} {-# RULES -"luminance :: RealFloat a => Color Y a -> Color Y a" luminance = id +"luminance :: RealFloat a => Color (Y i) a -> Color (Y i) a" luminance = id #-} diff --git a/Color/src/Graphics/Color/Space/RGB/AdobeRGB.hs b/Color/src/Graphics/Color/Space/RGB/AdobeRGB.hs index e17897f..cbb0f8d 100644 --- a/Color/src/Graphics/Color/Space/RGB/AdobeRGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/AdobeRGB.hs @@ -126,6 +126,10 @@ instance Elevator e => ColorSpace (AdobeRGB 'Linear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear @@ -140,6 +144,10 @@ instance Elevator e => ColorSpace (AdobeRGB 'NonLinear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbNonLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbNonLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgb2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgb diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs index f3358a4..9e808ed 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs @@ -96,6 +96,10 @@ instance (Typeable cs, ColorSpace (cs i l) i e, RedGreenBlue (cs i) i) => {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale = grayscale . toBaseSpace + {-# INLINE grayscale #-} + applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f) + {-# INLINE applyGrayscale #-} @@ -109,6 +113,10 @@ instance ColorSpace (SRGB l) D65 e => ColorSpace (CMYK (SRGB l)) D65 e where {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale = grayscale . toBaseSpace + {-# INLINE grayscale #-} + applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f) + {-# INLINE applyGrayscale #-} -- | `CMYK` representation for `AdobeRGB` color space instance ColorSpace (AdobeRGB l) D65 e => ColorSpace (CMYK (AdobeRGB l)) D65 e where @@ -120,6 +128,10 @@ instance ColorSpace (AdobeRGB l) D65 e => ColorSpace (CMYK (AdobeRGB l)) D65 e w {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale = grayscale . toBaseSpace + {-# INLINE grayscale #-} + applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f) + {-# INLINE applyGrayscale #-} -- | `CMYK` representation for `Rec470.BT470_525` color space instance ColorSpace (Rec470.BT470_525 l) D65 e => ColorSpace (CMYK (Rec470.BT470_525 l)) D65 e where @@ -131,6 +143,10 @@ instance ColorSpace (Rec470.BT470_525 l) D65 e => ColorSpace (CMYK (Rec470.BT470 {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale = grayscale . toBaseSpace + {-# INLINE grayscale #-} + applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f) + {-# INLINE applyGrayscale #-} -- | `CMYK` representation for `Rec470.BT470_625` color space instance ColorSpace (Rec470.BT470_625 l) D65 e => ColorSpace (CMYK (Rec470.BT470_625 l)) D65 e where @@ -142,6 +158,10 @@ instance ColorSpace (Rec470.BT470_625 l) D65 e => ColorSpace (CMYK (Rec470.BT470 {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale = grayscale . toBaseSpace + {-# INLINE grayscale #-} + applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f) + {-# INLINE applyGrayscale #-} -- | `CMYK` representation for `BT601_525` color space instance ColorSpace (BT601_525 l) D65 e => ColorSpace (CMYK (BT601_525 l)) D65 e where @@ -153,6 +173,10 @@ instance ColorSpace (BT601_525 l) D65 e => ColorSpace (CMYK (BT601_525 l)) D65 e {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale = grayscale . toBaseSpace + {-# INLINE grayscale #-} + applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f) + {-# INLINE applyGrayscale #-} -- | `CMYK` representation for `BT601_625` color space instance ColorSpace (BT601_625 l) D65 e => ColorSpace (CMYK (BT601_625 l)) D65 e where @@ -164,6 +188,10 @@ instance ColorSpace (BT601_625 l) D65 e => ColorSpace (CMYK (BT601_625 l)) D65 e {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale = grayscale . toBaseSpace + {-# INLINE grayscale #-} + applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f) + {-# INLINE applyGrayscale #-} -- | `CMYK` representation for `BT709` color space instance ColorSpace (BT709 l) D65 e => ColorSpace (CMYK (BT709 l)) D65 e where @@ -175,3 +203,7 @@ instance ColorSpace (BT709 l) D65 e => ColorSpace (CMYK (BT709 l)) D65 e where {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale = grayscale . toBaseSpace + {-# INLINE grayscale #-} + applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f) + {-# INLINE applyGrayscale #-} diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/HSI.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/HSI.hs index 7a128e5..d558643 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/HSI.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/HSI.hs @@ -83,9 +83,10 @@ pattern ColorH360SI h s i <- ColorHSI ((* 360) -> h) s i where -- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space instance ColorModel cs e => ColorModel (HSI cs) e where type Components (HSI cs) e = (e, e, e) - toComponents = toComponents . coerce + toComponents = + toComponents . (coerce :: Color (HSI cs) e -> Color CM.HSI e) {-# INLINE toComponents #-} - fromComponents = coerce . fromComponents + fromComponents = (coerce :: Color CM.HSI e -> Color (HSI cs) e) . fromComponents {-# INLINE fromComponents #-} showsColorModelName _ = ("HSI-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) @@ -94,9 +95,13 @@ instance ColorModel cs e => ColorModel (HSI cs) e where instance (ColorSpace (cs l) i e, RedGreenBlue cs i) => ColorSpace (HSI (cs l)) i e where type BaseModel (HSI (cs l)) = CM.HSI type BaseSpace (HSI (cs l)) = cs l - toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsi2rgb . fmap toDouble . coerce + toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsi2rgb . fmap toDouble . toBaseModel {-# INLINE toBaseSpace #-} - fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsi . fmap toDouble . unColorRGB + fromBaseSpace = fromBaseModel . fmap fromDouble . CM.rgb2hsi . fmap toDouble . unColorRGB {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 _ _ i) = X i + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 h s _) (X i) = coerce (V3 h s i) + {-# INLINE replaceGrayscale #-} diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/HSL.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/HSL.hs index 292f6d5..f0f1a46 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/HSL.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/HSL.hs @@ -82,9 +82,10 @@ pattern ColorH360SL h s i <- ColorHSL ((* 360) -> h) s i where -- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space instance ColorModel cs e => ColorModel (HSL cs) e where type Components (HSL cs) e = (e, e, e) - toComponents = toComponents . coerce + toComponents = + toComponents . (coerce :: Color (HSL cs) e -> Color CM.HSL e) {-# INLINE toComponents #-} - fromComponents = coerce . fromComponents + fromComponents = (coerce :: Color CM.HSL e -> Color (HSL cs) e) . fromComponents {-# INLINE fromComponents #-} showsColorModelName _ = ("HSL-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) @@ -93,9 +94,13 @@ instance ColorModel cs e => ColorModel (HSL cs) e where instance (ColorSpace (cs l) i e, RedGreenBlue cs i) => ColorSpace (HSL (cs l)) i e where type BaseModel (HSL (cs l)) = CM.HSL type BaseSpace (HSL (cs l)) = cs l - toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsl2rgb . fmap toDouble . coerce + toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsl2rgb . fmap toDouble . toBaseModel {-# INLINE toBaseSpace #-} - fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsl . fmap toDouble . unColorRGB + fromBaseSpace = fromBaseModel . fmap fromDouble . CM.rgb2hsl . fmap toDouble . unColorRGB {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 _ _ l) = X l + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 h s _) (X l) = coerce (V3 h s l) + {-# INLINE replaceGrayscale #-} diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/HSV.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/HSV.hs index a0ee6af..3b864bd 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/HSV.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/HSV.hs @@ -82,9 +82,10 @@ pattern ColorH360SV h s i <- ColorHSV ((* 360) -> h) s i where -- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space instance ColorModel cs e => ColorModel (HSV cs) e where type Components (HSV cs) e = (e, e, e) - toComponents = toComponents . coerce + toComponents = + toComponents . (coerce :: Color (HSV cs) e -> Color CM.HSV e) {-# INLINE toComponents #-} - fromComponents = coerce . fromComponents + fromComponents = (coerce :: Color CM.HSV e -> Color (HSV cs) e) . fromComponents {-# INLINE fromComponents #-} showsColorModelName _ = ("HSV-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) @@ -93,9 +94,13 @@ instance ColorModel cs e => ColorModel (HSV cs) e where instance (ColorSpace (cs l) i e, RedGreenBlue cs i) => ColorSpace (HSV (cs l)) i e where type BaseModel (HSV (cs l)) = CM.HSV type BaseSpace (HSV (cs l)) = cs l - toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsv2rgb . fmap toDouble . coerce + toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsv2rgb . fmap toDouble . toBaseModel {-# INLINE toBaseSpace #-} - fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsv . fmap toDouble . unColorRGB + fromBaseSpace = fromBaseModel . fmap fromDouble . CM.rgb2hsv . fmap toDouble . unColorRGB {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 _ _ v) = X v + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 h s _) (X v) = coerce (V3 h s v) + {-# INLINE replaceGrayscale #-} diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs index 4976534..f195a2b 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs @@ -11,6 +11,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Space.RGB.Alternative.YCbCr -- Copyright : (c) Alexey Kuleshevich 2019-2020 @@ -91,6 +92,10 @@ instance Elevator e => ColorSpace (Y'CbCr SRGB) D65 e where {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 y' _ _) = X y' + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 _ cb cr) (X y') = coerce (V3 y' cb cr) + {-# INLINE replaceGrayscale #-} instance Elevator e => ColorSpace (Y'CbCr BT601_525) D65 e where type BaseModel (Y'CbCr BT601_525) = CM.YCbCr @@ -101,6 +106,10 @@ instance Elevator e => ColorSpace (Y'CbCr BT601_525) D65 e where {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 y' _ _) = X y' + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 _ cb cr) (X y') = coerce (V3 y' cb cr) + {-# INLINE replaceGrayscale #-} instance Elevator e => ColorSpace (Y'CbCr BT601_625) D65 e where type BaseModel (Y'CbCr BT601_625) = CM.YCbCr @@ -111,6 +120,10 @@ instance Elevator e => ColorSpace (Y'CbCr BT601_625) D65 e where {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 y' _ _) = X y' + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 _ cb cr) (X y') = coerce (V3 y' cb cr) + {-# INLINE replaceGrayscale #-} instance Elevator e => ColorSpace (Y'CbCr BT709) D65 e where type BaseModel (Y'CbCr BT709) = CM.YCbCr @@ -121,6 +134,10 @@ instance Elevator e => ColorSpace (Y'CbCr BT709) D65 e where {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 y' _ _) = X y' + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 _ cb cr) (X y') = coerce (V3 y' cb cr) + {-# INLINE replaceGrayscale #-} instance (Typeable cs, Luma (cs i), ColorSpace (cs i 'NonLinear) i e, RedGreenBlue (cs i) i) => ColorSpace (Y'CbCr (cs i)) i e where @@ -132,6 +149,10 @@ instance (Typeable cs, Luma (cs i), ColorSpace (cs i 'NonLinear) i e, RedGreenBl {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 y' _ _) = X y' + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 _ cb cr) (X y') = coerce (V3 y' cb cr) + {-# INLINE replaceGrayscale #-} -- | This conversion is only correct for sRGB and Rec601. Source: ITU-T Rec. T.871 @@ -139,13 +160,7 @@ instance (Typeable cs, Luma (cs i), ColorSpace (cs i 'NonLinear) i e, RedGreenBl -- @since 0.1.3 ycbcr2srgb :: (RedGreenBlue cs i, RealFloat e) => Color (Y'CbCr cs) e -> Color (cs 'NonLinear) e -ycbcr2srgb (ColorY'CbCr y' cb cr) = ColorRGB r' g' b' - where - !cb05 = cb - 0.5 - !cr05 = cr - 0.5 - !r' = clamp01 (y' + 1.402 * cr05) - !g' = clamp01 (y' - 0.344136 * cb05 - 0.714136 * cr05) - !b' = clamp01 (y' + 1.772 * cb05) +ycbcr2srgb = ycbcrToRec601 . coerce {-# INLINE ycbcr2srgb #-} -- | This conversion is only correct for sRGB and Rec601. Source: ITU-T Rec. T.871 @@ -153,11 +168,7 @@ ycbcr2srgb (ColorY'CbCr y' cb cr) = ColorRGB r' g' b' -- @since 0.1.3 srgb2ycbcr :: (RedGreenBlue cs i, RealFloat e) => Color (cs 'NonLinear) e -> Color (Y'CbCr cs) e -srgb2ycbcr (ColorRGB r' g' b') = ColorY'CbCr y' cb cr - where - !y' = 0.299 * r' + 0.587 * g' + 0.114 * b' - !cb = 0.5 - 0.168736 * r' - 0.331264 * g' + 0.5 * b' - !cr = 0.5 + 0.5 * r' - 0.418688 * g' - 0.081312 * b' +srgb2ycbcr = coerce . rec601ToYcbcr {-# INLINE srgb2ycbcr #-} -- | Convert any RGB color space that has `Luma` specified to `Y'CbCr` diff --git a/Color/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs b/Color/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs index 9cf4edf..f8d6460 100644 --- a/Color/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs @@ -72,6 +72,10 @@ instance (Illuminant i, Elevator e) => ColorSpace (AdobeRGB i 'Linear) i e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear @@ -86,6 +90,10 @@ instance (Illuminant i, Elevator e) => ColorSpace (AdobeRGB i 'NonLinear) i e wh {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbNonLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbNonLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgb2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgb diff --git a/Color/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs b/Color/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs index 2fca8ec..c848163 100644 --- a/Color/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs @@ -74,6 +74,10 @@ instance (Illuminant i, Typeable l, Elevator e) => ColorSpace (CIERGB i l) i e w {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . castLinearity . fmap toRealFloat {-# INLINE luminance #-} + grayscale = toBaseModel . fmap fromDouble . luminance + {-# INLINE grayscale #-} + applyGrayscale c f = castLinearity (rgbLinearApplyGrayscale (castLinearity c) f) + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat . castLinearity {-# INLINE toColorXYZ #-} fromColorXYZ xyz = castLinearity (fromRealFloat <$> xyz2rgbLinear @(CIERGB i) xyz) diff --git a/Color/src/Graphics/Color/Space/RGB/Derived/SRGB.hs b/Color/src/Graphics/Color/Space/RGB/Derived/SRGB.hs index afb7943..539d680 100644 --- a/Color/src/Graphics/Color/Space/RGB/Derived/SRGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/Derived/SRGB.hs @@ -21,6 +21,7 @@ module Graphics.Color.Space.RGB.Derived.SRGB ( SRGB ) where +import Data.Coerce import Data.Typeable import Foreign.Storable import Graphics.Color.Model.Internal @@ -29,7 +30,7 @@ import Graphics.Color.Space.Internal import Graphics.Color.Space.RGB.Internal import Graphics.Color.Space.RGB.Luma import qualified Graphics.Color.Space.RGB.SRGB as SRGB - +import Graphics.Color.Space.RGB.ITU.Rec601 (applyGrayscaleRec601) -- | The most common @sRGB@ color space with an arbitrary illuminant data SRGB (i :: k) (l :: Linearity) @@ -73,6 +74,10 @@ instance (Illuminant i, Elevator e) => ColorSpace (SRGB i 'Linear) i e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear @@ -88,6 +93,10 @@ instance (Illuminant i, Elevator e) => ColorSpace (SRGB i 'NonLinear) i e where {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = fmap fromDouble . coerce . rgbLuma @_ @_ @_ @Double + {-# INLINE grayscale #-} + applyGrayscale = applyGrayscaleRec601 + {-# INLINE applyGrayscale #-} toColorXYZ = rgb2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgb diff --git a/Color/src/Graphics/Color/Space/RGB/ITU/Rec470.hs b/Color/src/Graphics/Color/Space/RGB/ITU/Rec470.hs index 1728ddd..b1ebf03 100644 --- a/Color/src/Graphics/Color/Space/RGB/ITU/Rec470.hs +++ b/Color/src/Graphics/Color/Space/RGB/ITU/Rec470.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -77,6 +78,10 @@ instance Elevator e => ColorSpace (BT470_525 'Linear) C e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear @@ -91,6 +96,10 @@ instance Elevator e => ColorSpace (BT470_525 'NonLinear) C e where {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbNonLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbNonLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgb2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgb @@ -151,6 +160,10 @@ instance Elevator e => ColorSpace (BT470_625 'Linear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear @@ -165,6 +178,10 @@ instance Elevator e => ColorSpace (BT470_625 'NonLinear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbNonLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbNonLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgb2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgb diff --git a/Color/src/Graphics/Color/Space/RGB/ITU/Rec601.hs b/Color/src/Graphics/Color/Space/RGB/ITU/Rec601.hs index da0893b..5b389b4 100644 --- a/Color/src/Graphics/Color/Space/RGB/ITU/Rec601.hs +++ b/Color/src/Graphics/Color/Space/RGB/ITU/Rec601.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -6,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -23,13 +25,18 @@ module Graphics.Color.Space.RGB.ITU.Rec601 , pattern BT601_625 , BT601_625 , D65 + , ycbcrToRec601 + , rec601ToYcbcr + , applyGrayscaleRec601 ) where +import Data.Coerce import Data.Typeable import Foreign.Storable import Graphics.Color.Illuminant.ITU.Rec601 import Graphics.Color.Model.Internal import qualified Graphics.Color.Model.RGB as CM +import qualified Graphics.Color.Model.YCbCr as CM import Graphics.Color.Space.Internal import Graphics.Color.Space.RGB.Internal import Graphics.Color.Space.RGB.ITU.Rec470 (BT470_625) @@ -82,6 +89,10 @@ instance Elevator e => ColorSpace (BT601_525 'Linear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear @@ -97,6 +108,10 @@ instance Elevator e => ColorSpace (BT601_525 'NonLinear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = fmap fromDouble . coerce . rgbLuma @_ @_ @_ @Double + {-# INLINE grayscale #-} + applyGrayscale = applyGrayscaleRec601 + {-# INLINE applyGrayscale #-} toColorXYZ = rgb2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgb @@ -157,6 +172,10 @@ instance Elevator e => ColorSpace (BT601_625 'Linear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear @@ -171,6 +190,10 @@ instance Elevator e => ColorSpace (BT601_625 'NonLinear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = fmap fromDouble . coerce . rgbLuma @_ @_ @_ @Double + {-# INLINE grayscale #-} + applyGrayscale = applyGrayscaleRec601 + {-# INLINE applyGrayscale #-} toColorXYZ = rgb2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgb @@ -231,3 +254,45 @@ itransferRec601 e inv0018 :: (Ord a, Floating a) => a inv0018 = transferRec601 0.018 -- ~ 0.081 + + +-- | This conversion is correct only for sRGB and Rec601. Source: ITU-T Rec. T.871 +-- +-- @since 0.1.3 +ycbcrToRec601 :: + (RedGreenBlue cs i, RealFloat e) + => Color CM.YCbCr e + -> Color (cs 'NonLinear) e +ycbcrToRec601 (CM.ColorYCbCr y' cb cr) = mkColorRGB (CM.ColorRGB r' g' b') + where + !cb05 = cb - 0.5 + !cr05 = cr - 0.5 + !r' = clamp01 (y' + 1.402 * cr05) + !g' = clamp01 (y' - 0.344136 * cb05 - 0.714136 * cr05) + !b' = clamp01 (y' + 1.772 * cb05) +{-# INLINE ycbcrToRec601 #-} + +-- | This conversion is correct only for sRGB and Rec601. Source: ITU-T Rec. T.871 +-- +-- @since 0.1.3 +rec601ToYcbcr :: (RedGreenBlue cs i, RealFloat e) => Color (cs 'NonLinear) e -> Color CM.YCbCr e +rec601ToYcbcr rgb = CM.ColorYCbCr y' cb cr + where + CM.ColorRGB r' g' b' = unColorRGB rgb + !y' = 0.299 * r' + 0.587 * g' + 0.114 * b' + !cb = 0.5 - 0.168736 * r' - 0.331264 * g' + 0.5 * b' + !cr = 0.5 + 0.5 * r' - 0.418688 * g' - 0.081312 * b' +{-# INLINE rec601ToYcbcr #-} + + +applyGrayscaleRec601 :: + forall cs i e. (RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e) + => Color (cs 'NonLinear) e + -> (Color X e -> Color X e) + -> Color (cs 'NonLinear) e +applyGrayscaleRec601 rgb f = + case rec601ToYcbcr (toDouble <$> rgb) of + (CM.ColorYCbCr y' cb cr :: Color CM.YCbCr Double) -> + fromDouble <$> + ycbcrToRec601 (CM.ColorYCbCr (toDouble (coerce (f (X (fromDouble y'))) :: e)) cb cr) +{-# INLINE applyGrayscaleRec601 #-} diff --git a/Color/src/Graphics/Color/Space/RGB/ITU/Rec709.hs b/Color/src/Graphics/Color/Space/RGB/ITU/Rec709.hs index 7b34e91..f0e75a5 100644 --- a/Color/src/Graphics/Color/Space/RGB/ITU/Rec709.hs +++ b/Color/src/Graphics/Color/Space/RGB/ITU/Rec709.hs @@ -73,6 +73,10 @@ instance Elevator e => ColorSpace (BT709 'Linear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear @@ -87,6 +91,10 @@ instance Elevator e => ColorSpace (BT709 'NonLinear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbNonLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbNonLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgb2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgb diff --git a/Color/src/Graphics/Color/Space/RGB/Internal.hs b/Color/src/Graphics/Color/Space/RGB/Internal.hs index 6524b76..acc0e00 100644 --- a/Color/src/Graphics/Color/Space/RGB/Internal.hs +++ b/Color/src/Graphics/Color/Space/RGB/Internal.hs @@ -39,6 +39,10 @@ module Graphics.Color.Space.RGB.Internal , xyz2rgbLinear , rgbLuminance , rgbLinearLuminance + , rgbLinearGrayscale + , rgbLinearApplyGrayscale + , rgbNonLinearGrayscale + , rgbNonLinearApplyGrayscale , NPM(..) , npmApply , npmDerive @@ -219,6 +223,44 @@ rgbLinearLuminance px = Y (m3x3row1 (unNPM (npm :: NPM cs e)) `dotProduct` coerce (unColorRGB px)) {-# INLINE rgbLinearLuminance #-} +rgbLinearGrayscale :: + forall cs i e. (ColorSpace (cs 'Linear) i e) + => Color (cs 'Linear) e + -> Color X e +rgbLinearGrayscale = ColorX . fromDouble . unY . luminance +{-# INLINE rgbLinearGrayscale #-} + + +rgbLinearApplyGrayscale :: + forall cs i e. (ColorSpace (cs 'Linear) i e) + => Color (cs 'Linear) e + -> (Color X e -> Color X e) + -> Color (cs 'Linear) e +rgbLinearApplyGrayscale rgb f = + case toColorXYZ rgb of + ColorXYZ x y z -> + fromColorXYZ (ColorXYZ x (toDouble (coerce (f (X (fromDouble y))) :: e)) z) +{-# INLINE rgbLinearApplyGrayscale #-} + + +rgbNonLinearApplyGrayscale :: + forall cs i e. (RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e) + => Color (cs 'NonLinear) e + -> (Color X e -> Color X e) + -> Color (cs 'NonLinear) e +rgbNonLinearApplyGrayscale rgb f = + case toColorXYZ rgb of + ColorXYZ x y z -> + let y' = itransfer @_ @cs (toDouble (coerce (f (X (fromDouble (transfer @_ @cs y)))) :: e)) + in fromColorXYZ (ColorXYZ x y' z) +{-# INLINE rgbNonLinearApplyGrayscale #-} + +rgbNonLinearGrayscale :: + forall cs i e. (RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e) + => Color (cs 'NonLinear) e + -> Color X e +rgbNonLinearGrayscale = ColorX . fromDouble . (transfer @_ @cs) . unY . luminance +{-# INLINE rgbNonLinearGrayscale #-} rgbLuminance :: (RedGreenBlue cs i, ColorSpace (cs 'Linear) i e, RealFloat e) diff --git a/Color/src/Graphics/Color/Space/RGB/Luma.hs b/Color/src/Graphics/Color/Space/RGB/Luma.hs index 93a50bb..2f8d220 100644 --- a/Color/src/Graphics/Color/Space/RGB/Luma.hs +++ b/Color/src/Graphics/Color/Space/RGB/Luma.hs @@ -112,6 +112,13 @@ instance ( Typeable cs {-# INLINE toBaseSpace #-} fromBaseSpace = fmap fromDouble . rgbLuma {-# INLINE fromBaseSpace #-} + grayscale = coerce + {-# INLINE grayscale #-} + applyGrayscale c f = coerce (f (coerce c)) + {-# INLINE applyGrayscale #-} + replaceGrayscale _ = coerce + {-# INLINE replaceGrayscale #-} + -- luminance = luminance . toBaseLinearSpace luminance = luminance . fmap (fromDouble :: Double -> e) . toBaseLinearSpace . fmap toDouble {-# INLINE luminance #-} toColorXYZ = toColorXYZ . fmap (fromDouble :: Double -> e) . toBaseLinearSpace . fmap toDouble diff --git a/Color/src/Graphics/Color/Space/RGB/SRGB.hs b/Color/src/Graphics/Color/Space/RGB/SRGB.hs index 645030f..89b0384 100644 --- a/Color/src/Graphics/Color/Space/RGB/SRGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/SRGB.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -36,6 +37,7 @@ import Graphics.Color.Model.Internal import qualified Graphics.Color.Model.RGB as CM import Graphics.Color.Space.Internal import Graphics.Color.Space.RGB.Internal +import Graphics.Color.Space.RGB.ITU.Rec601 (applyGrayscaleRec601) import Graphics.Color.Space.RGB.ITU.Rec709 (BT709, D65) import Graphics.Color.Space.RGB.Luma @@ -136,6 +138,10 @@ instance Elevator e => ColorSpace (SRGB 'Linear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLinearLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = rgbLinearGrayscale + {-# INLINE grayscale #-} + applyGrayscale = rgbLinearApplyGrayscale + {-# INLINE applyGrayscale #-} toColorXYZ = rgbLinear2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear @@ -151,6 +157,10 @@ instance Elevator e => ColorSpace (SRGB 'NonLinear) D65 e where {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} + grayscale = fmap fromDouble . coerce . rgbLuma @_ @_ @_ @Double + {-# INLINE grayscale #-} + applyGrayscale = applyGrayscaleRec601 + {-# INLINE applyGrayscale #-} toColorXYZ = rgb2xyz . fmap toRealFloat {-# INLINE toColorXYZ #-} fromColorXYZ = fmap fromRealFloat . xyz2rgb diff --git a/Color/tests/Graphics/Color/Space/Common.hs b/Color/tests/Graphics/Color/Space/Common.hs index e65ee6a..cb5db2c 100644 --- a/Color/tests/Graphics/Color/Space/Common.hs +++ b/Color/tests/Graphics/Color/Space/Common.hs @@ -16,11 +16,15 @@ module Graphics.Color.Space.Common , prop_toFromBaseSpace ) where +import Data.Coerce import Graphics.Color.Space import Graphics.Color.Model.Common +instance (Elevator e, Random e) => Arbitrary (Color X e) where + arbitrary = coerce $ arbitraryElevator @e + instance (Elevator e, Random e) => Arbitrary (Color (Y i) e) where - arbitrary = Y <$> arbitraryElevator + arbitrary = coerce $ arbitraryElevator @e instance (Elevator e, Random e) => Arbitrary (Color (XYZ i) e) where arbitrary = ColorXYZ <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator @@ -67,6 +71,44 @@ prop_toFromBaseModel :: -> Property prop_toFromBaseModel c = c === fromBaseModel (toBaseModel c) +prop_toApplyGrayscale :: + forall cs e i. (ColorSpace cs i e, RealFloat e) + => e + -> Color cs e + -> Property +prop_toApplyGrayscale epsilon c = epsilonEqColorTol epsilon c $ applyGrayscale c id + +prop_toReplaceGrayscale :: + forall cs e i. (ColorSpace cs i e, RealFloat e) + => e + -> Color cs e + -> Property +prop_toReplaceGrayscale epsilon c = + epsilonEqColorTol epsilon c (replaceGrayscale c (grayscale c)) + +prop_toApplyGrayscaleAsReplace :: + forall cs e i. (ColorSpace cs i e, RealFloat e) + => e + -> Color cs e + -> Fun (Color X e) (Color X e) + -> Property +prop_toApplyGrayscaleAsReplace epsilon c f = + epsilonEqColorTol + epsilon + (applyGrayscale c (applyFun f)) + (replaceGrayscale c (applyFun f (grayscale c))) + + +prop_toReplaceGrayscaleAsApply :: + forall cs e i. (ColorSpace cs i e, RealFloat e) + => e + -> Color cs e + -> Color X e + -> Property +prop_toReplaceGrayscaleAsApply epsilon c y = + epsilonEqColorTol epsilon (replaceGrayscale c y) (applyGrayscale c (const y)) + + colorSpaceCommonSpec :: forall cs e i. (Arbitrary (Color cs e), ColorSpace cs i e) @@ -88,7 +130,14 @@ colorSpaceSpec = colorSpaceLenientSpec :: forall cs e i. - (Arbitrary (Color cs e), ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, RealFloat e) + ( Arbitrary (Color cs e) + , ColorSpace (BaseSpace cs) i e + , ColorSpace cs i e + , RealFloat e + , Function e + , Random e + , CoArbitrary e + ) => e -> Spec colorSpaceLenientSpec tol = @@ -96,3 +145,7 @@ colorSpaceLenientSpec tol = in colorSpaceCommonSpec @cs @e @i $ do prop ("toFromBaseSpace " ++ tolStr) $ prop_toFromBaseSpaceLenient @cs @e @i tol prop ("toFromColorXYZ " ++ tolStr) $ prop_toFromLenientColorXYZ @cs @e @i tol + prop ("toReplaceGrayscale " ++ tolStr) $ prop_toReplaceGrayscale @cs @e @i tol + prop ("toReplaceGrayscaleAsApply " ++ tolStr) $ prop_toReplaceGrayscaleAsApply @cs @e @i tol + prop ("toApplyGrayscale" ++ tolStr) $ prop_toApplyGrayscale @cs @e @i tol + prop ("toApplyGrayscaleAsReplace" ++ tolStr) $ prop_toApplyGrayscaleAsReplace @cs @e @i tol From 9752ed70a80637caadb513bb0691ce8d25dc8e4b Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Sun, 8 Nov 2020 05:57:58 +0300 Subject: [PATCH 02/11] Add pixel version of grayscale functions --- Color/src/Graphics/Pixel/ColorSpace.hs | 30 +++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/Color/src/Graphics/Pixel/ColorSpace.hs b/Color/src/Graphics/Pixel/ColorSpace.hs index 9293f2f..4df2305 100644 --- a/Color/src/Graphics/Pixel/ColorSpace.hs +++ b/Color/src/Graphics/Pixel/ColorSpace.hs @@ -28,6 +28,10 @@ module Graphics.Pixel.ColorSpace , fromPixelXYZ , toPixelBaseSpace , fromPixelBaseSpace + -- * Grayscale + , grayscalePixel + , applyGrayscalePixel + , replaceGrayscalePixel -- ** Color model , toPixelBaseModel , fromPixelBaseModel @@ -319,7 +323,7 @@ toPixelBaseSpace :: toPixelBaseSpace = liftPixel toBaseSpace {-# INLINE toPixelBaseSpace #-} --- | Covert a color space of a pixel into it's alternative representation. Example AdobeRGB to HSI. +-- | Covert a color space of a pixel into its alternative representation. Example AdobeRGB to HSI. -- -- @since 0.1.0 fromPixelBaseSpace :: @@ -327,6 +331,30 @@ fromPixelBaseSpace :: fromPixelBaseSpace = liftPixel fromBaseSpace {-# INLINE fromPixelBaseSpace #-} +-- | Drop chroma information from a pixel. Same as `grayscale` for `Color` +-- +-- @since 0.4.0 +grayscalePixel :: ColorSpace cs i e => Pixel cs e -> Pixel X e +grayscalePixel = liftPixel grayscale +{-# INLINE grayscalePixel #-} + + +-- | Apply a function to grayscale information of a pixel leaving chroma untouched. Same +-- as `applyGrayscale` for `Color` +-- +-- @since 0.4.0 +applyGrayscalePixel :: ColorSpace cs i e => Pixel cs e -> (Pixel X e -> Pixel X e) -> Pixel cs e +applyGrayscalePixel c f = coerce (applyGrayscale (coerce c) (coerce f)) +{-# INLINE applyGrayscalePixel #-} + +-- | Replace grayscale information in a pixel leaving chroma untouched. Same as +-- `replaceGrayscale` for `Color` +-- +-- @since 0.4.0 +replaceGrayscalePixel :: ColorSpace cs i e => Pixel cs e -> Pixel X e -> Pixel cs e +replaceGrayscalePixel c e = coerce (replaceGrayscale (coerce c) (coerce e)) +{-# INLINE replaceGrayscalePixel #-} + -- -- | Constructor for a pixel in @sRGB@ color space with 8-bits per channel -- pattern PixelRGB8 :: Word8 -> Word8 -> Word8 -> Pixel SRGB Word8 From affdf8fef360f0a463f8cee6d2d8909eba0f1694 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Mon, 9 Nov 2020 07:06:17 +0300 Subject: [PATCH 03/11] Addition of: `ChannelCount`, `channelCount`, `channelNames` and `channelColors` --- Color/CHANGELOG.md | 1 + Color/src/Graphics/Color/Model/CMYK.hs | 16 ++++++++-- Color/src/Graphics/Color/Model/HSI.hs | 7 +++++ Color/src/Graphics/Color/Model/HSL.hs | 7 +++++ Color/src/Graphics/Color/Model/HSV.hs | 11 +++++-- Color/src/Graphics/Color/Model/Internal.hs | 30 +++++++++++++++++-- Color/src/Graphics/Color/Model/RGB.hs | 10 +++++++ Color/src/Graphics/Color/Model/X.hs | 7 +++++ Color/src/Graphics/Color/Model/YCbCr.hs | 6 ++++ Color/src/Graphics/Color/Space/CIE1931/RGB.hs | 5 ++++ Color/src/Graphics/Color/Space/CIE1976/LAB.hs | 10 +++++++ Color/src/Graphics/Color/Space/Internal.hs | 24 ++++++++++++--- .../src/Graphics/Color/Space/RGB/AdobeRGB.hs | 6 ++++ .../Color/Space/RGB/Alternative/CMYK.hs | 5 ++++ .../Color/Space/RGB/Alternative/HSI.hs | 8 +++-- .../Color/Space/RGB/Alternative/HSL.hs | 8 +++-- .../Color/Space/RGB/Alternative/HSV.hs | 8 +++-- .../Color/Space/RGB/Alternative/YCbCr.hs | 5 ++++ .../Color/Space/RGB/Derived/AdobeRGB.hs | 5 ++++ .../Color/Space/RGB/Derived/CIERGB.hs | 5 ++++ .../Graphics/Color/Space/RGB/Derived/SRGB.hs | 5 ++++ .../Graphics/Color/Space/RGB/ITU/Rec470.hs | 10 +++++++ .../Graphics/Color/Space/RGB/ITU/Rec601.hs | 10 +++++++ .../Graphics/Color/Space/RGB/ITU/Rec709.hs | 6 ++++ Color/src/Graphics/Color/Space/RGB/Luma.hs | 6 ++++ Color/src/Graphics/Color/Space/RGB/SRGB.hs | 5 ++++ Color/src/Graphics/Pixel/ColorSpace.hs | 3 +- Color/tests/Graphics/Color/Model/Common.hs | 8 +++++ 28 files changed, 219 insertions(+), 18 deletions(-) diff --git a/Color/CHANGELOG.md b/Color/CHANGELOG.md index a0fdc55..f7967fd 100644 --- a/Color/CHANGELOG.md +++ b/Color/CHANGELOG.md @@ -3,6 +3,7 @@ ## 0.3.4 * Addition of: `toGrayscale`, `applyGrayscale` and `replaceGrayscale`. +* Addition of: `ChannelCount`, `channelCount`, `channelNames` and `channelColors` ## 0.3.3 diff --git a/Color/src/Graphics/Color/Model/CMYK.hs b/Color/src/Graphics/Color/Model/CMYK.hs index 0b0c5dd..4f9bd7d 100644 --- a/Color/src/Graphics/Color/Model/CMYK.hs +++ b/Color/src/Graphics/Color/Model/CMYK.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Model.CMYK @@ -25,6 +26,7 @@ module Graphics.Color.Model.CMYK , rgb2cmyk ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Model.RGB @@ -55,6 +57,14 @@ instance Elevator e => Show (Color CMYK e) where -- | `CMYK` color model instance Elevator e => ColorModel CMYK e where type Components CMYK e = (e, e, e, e) + type ChannelCount CMYK = 4 + channelCount _ = 4 + {-# INLINE channelCount #-} + channelNames _ = "Cyan" :| ["Magenta", "Yellow", "Key"] + channelColors _ = V3 0x00 0xff 0xff :| + [ V3 0xff 0x00 0xff + , V3 0xff 0xff 0x00 + , V3 0xff 0xff 0xff ] toComponents (ColorCMYK c m y k) = (c, m, y, k) {-# INLINE toComponents #-} fromComponents (c, m, y, k) = ColorCMYK c m y k @@ -69,7 +79,7 @@ instance Functor (Color CMYK) where instance Applicative (Color CMYK) where pure !e = ColorCMYK e e e e {-# INLINE pure #-} - (ColorCMYK fc fm fy fk) <*> (ColorCMYK c m y k) = ColorCMYK (fc c) (fm m) (fy y) (fk k) + ColorCMYK fc fm fy fk <*> ColorCMYK c m y k = ColorCMYK (fc c) (fm m) (fy y) (fk k) {-# INLINE (<*>) #-} -- | `CMYK` color model diff --git a/Color/src/Graphics/Color/Model/HSI.hs b/Color/src/Graphics/Color/Model/HSI.hs index 48f4dad..6f33f7a 100644 --- a/Color/src/Graphics/Color/Model/HSI.hs +++ b/Color/src/Graphics/Color/Model/HSI.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -29,6 +30,7 @@ module Graphics.Color.Model.HSI , rgb2hsi ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Model.RGB @@ -85,6 +87,11 @@ instance Elevator e => Show (Color HSI e) where -- | `HSI` color model instance Elevator e => ColorModel HSI e where type Components HSI e = (e, e, e) + type ChannelCount HSI = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "Hue" :| ["Saturation", "Intensity"] + channelColors _ = V3 0x94 0x00 0xd3 :| [V3 0xff 0x8c 0x00, V3 0x00 0xce 0xd1] toComponents (ColorHSI h s i) = (h, s, i) {-# INLINE toComponents #-} fromComponents (h, s, i) = ColorHSI h s i diff --git a/Color/src/Graphics/Color/Model/HSL.hs b/Color/src/Graphics/Color/Model/HSL.hs index e441ac2..ce8afea 100644 --- a/Color/src/Graphics/Color/Model/HSL.hs +++ b/Color/src/Graphics/Color/Model/HSL.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -30,6 +31,7 @@ module Graphics.Color.Model.HSL , rgb2hsl ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.HSV (hc2rgb) import Graphics.Color.Model.Internal @@ -86,6 +88,11 @@ instance Elevator e => Show (Color HSL e) where -- | `HSL` color model instance Elevator e => ColorModel HSL e where type Components HSL e = (e, e, e) + type ChannelCount HSL = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "Hue" :| ["Saturation", "Lightness"] + channelColors _ = V3 0x94 0x00 0xd3 :| [V3 0xff 0x8c 0x00, V3 0xaf 0xee 0xee] toComponents (ColorHSL h s l) = (h, s, l) {-# INLINE toComponents #-} fromComponents (h, s, l) = ColorHSL h s l diff --git a/Color/src/Graphics/Color/Model/HSV.hs b/Color/src/Graphics/Color/Model/HSV.hs index 90951d3..0b96cfb 100644 --- a/Color/src/Graphics/Color/Model/HSV.hs +++ b/Color/src/Graphics/Color/Model/HSV.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -30,6 +31,7 @@ module Graphics.Color.Model.HSV , rgb2hsv ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Model.RGB @@ -85,6 +87,11 @@ instance Elevator e => Show (Color HSV e) where -- | `HSV` color model instance Elevator e => ColorModel HSV e where type Components HSV e = (e, e, e) + type ChannelCount HSV = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "Hue" :| ["Saturation", "Value"] + channelColors _ = V3 0x94 0x00 0xd3 :| [V3 0xff 0x8c 0x00, V3 0x5f 0x9e 0x90] toComponents (ColorHSV h s v) = (h, s, v) {-# INLINE toComponents #-} fromComponents (h, s, v) = ColorHSV h s v diff --git a/Color/src/Graphics/Color/Model/Internal.hs b/Color/src/Graphics/Color/Model/Internal.hs index 4546149..7744499 100644 --- a/Color/src/Graphics/Color/Model/Internal.hs +++ b/Color/src/Graphics/Color/Model/Internal.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Graphics.Color.Model.Internal @@ -43,10 +44,11 @@ module Graphics.Color.Model.Internal , VU.Vector(V_Color) ) where +import Data.List.NonEmpty as NE import Control.Applicative import Control.DeepSeq (NFData(rnf), deepseq) import Data.Default.Class (Default(..)) -import Data.Foldable +import Data.Foldable as F import Data.Kind import Data.Typeable import qualified Data.Vector.Generic as V @@ -75,12 +77,30 @@ class ( Functor (Color cs) ) => ColorModel cs e where type Components cs e :: Type + type ChannelCount cs :: Nat -- | Convert a Color to a representation suitable for storage as an unboxed -- element, usually a tuple of channels. toComponents :: Color cs e -> Components cs e -- | Convert from an elemnt representation back to a Color. fromComponents :: Components cs e -> Color cs e + -- | Number of channels in the color model (eg. RGB has three). Must be a positive number. + -- + -- @since 0.3.1 + channelCount :: Proxy (Color cs e) -> Int + + -- | Textual name for each of the channels + -- + -- @since 0.3.1 + channelNames :: Proxy (Color cs e) -> NonEmpty String + + -- | Some 8bit sRGB values for each of the channels that might or might not have some + -- meaningful relation to the actual colors in each channel. This is useful for plotting + -- values. + -- + -- @since 0.3.1 + channelColors :: Proxy (Color cs e) -> NonEmpty (V3 Word8) + -- | Display the @cs@ portion of the pixel. Color itself will not be evaluated. -- -- @since 0.1.0 @@ -219,7 +239,7 @@ showsColorModelOpen px = t . (":(" ++) . channels . (')' :) where t = asProxy px showsColorModelName channels = - case toList px of + case F.toList px of [] -> id (x:xs) -> foldl' (\facc y -> facc . (channelSeparator :) . toShowS y) (toShowS x) xs @@ -357,6 +377,12 @@ type family Opaque cs where instance (ColorModel cs e, cs ~ Opaque (Alpha cs)) => ColorModel (Alpha cs) e where type Components (Alpha cs) e = (Components cs e, e) + type ChannelCount (Alpha cs) = 1 + ChannelCount cs + channelCount _ = 1 + channelCount (Proxy :: Proxy (Color cs e)) + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color cs e)) <> ("Alpha" :| []) + channelColors _ = + channelColors (Proxy :: Proxy (Color cs e)) <> (V3 0xe6 0xe6 0xfa :| []) -- <- lavander toComponents (Alpha px a) = (toComponents px, a) {-# INLINE toComponents #-} fromComponents (pxc, a) = Alpha (fromComponents pxc) a diff --git a/Color/src/Graphics/Color/Model/RGB.hs b/Color/src/Graphics/Color/Model/RGB.hs index 3212e2a..b0e2a28 100644 --- a/Color/src/Graphics/Color/Model/RGB.hs +++ b/Color/src/Graphics/Color/Model/RGB.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -26,6 +27,7 @@ module Graphics.Color.Model.RGB , ColorModel(..) ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Algebra import Graphics.Color.Model.Internal @@ -58,6 +60,14 @@ instance Elevator e => Show (Color RGB e) where -- | `RGB` color model instance Elevator e => ColorModel RGB e where type Components RGB e = (e, e, e) + type ChannelCount RGB = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "Red" :| ["Green", "Blue"] + channelColors _ = V3 0xff 0x00 0x00 :| + [ V3 0x00 0xff 0x00 + , V3 0x00 0x00 0xff + ] toComponents (ColorRGB r g b) = (r, g, b) {-# INLINE toComponents #-} fromComponents (r, g, b) = ColorRGB r g b diff --git a/Color/src/Graphics/Color/Model/X.hs b/Color/src/Graphics/Color/Model/X.hs index 64d00f4..177976d 100644 --- a/Color/src/Graphics/Color/Model/X.hs +++ b/Color/src/Graphics/Color/Model/X.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -25,6 +26,7 @@ module Graphics.Color.Model.X , rgb2y ) where +import Data.List.NonEmpty import Data.Coerce import Foreign.Storable import Graphics.Color.Model.Internal @@ -65,6 +67,11 @@ instance Elevator e => Show (Color X e) where -- | `X` color model instance Elevator e => ColorModel X e where type Components X e = e + type ChannelCount X = 1 + channelCount _ = 1 + {-# INLINE channelCount #-} + channelNames _ = "Gray" :| [] + channelColors _ = V3 0x80 0x80 0x80 :| [] toComponents (X y) = y {-# INLINE toComponents #-} fromComponents = X diff --git a/Color/src/Graphics/Color/Model/YCbCr.hs b/Color/src/Graphics/Color/Model/YCbCr.hs index 5261d8b..cfdb676 100644 --- a/Color/src/Graphics/Color/Model/YCbCr.hs +++ b/Color/src/Graphics/Color/Model/YCbCr.hs @@ -28,6 +28,7 @@ module Graphics.Color.Model.YCbCr , ycbcr2rgb ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Model.RGB @@ -72,6 +73,11 @@ pattern ColorYCbCrA y cb cr a = Alpha (YCbCr (V3 y cb cr)) a -- | `YCbCr` color model instance Elevator e => ColorModel YCbCr e where type Components YCbCr e = (e, e, e) + type ChannelCount YCbCr = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "Luma" :| ["Blue Chroma Diff", "Red Chroma Diff"] + channelColors _ = V3 0x80 0x80 0x80 :| [V3 0x00 0x00 0x80, V3 0x8b 0x00 0x00] toComponents (ColorYCbCr y cb cr) = (y, cb, cr) {-# INLINE toComponents #-} fromComponents (y, cb, cr) = ColorYCbCr y cb cr diff --git a/Color/src/Graphics/Color/Space/CIE1931/RGB.hs b/Color/src/Graphics/Color/Space/CIE1931/RGB.hs index 2b575e5..f37ce67 100644 --- a/Color/src/Graphics/Color/Space/CIE1931/RGB.hs +++ b/Color/src/Graphics/Color/Space/CIE1931/RGB.hs @@ -60,6 +60,11 @@ instance (Typeable l, Elevator e) => Show (Color (CIERGB l) e) where -- | `CIERGB` color space instance (Typeable l, Elevator e) => ColorModel (CIERGB l) e where type Components (CIERGB l) e = (e, e, e) + type ChannelCount (CIERGB l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents diff --git a/Color/src/Graphics/Color/Space/CIE1976/LAB.hs b/Color/src/Graphics/Color/Space/CIE1976/LAB.hs index 7f4aa11..f23e8a4 100644 --- a/Color/src/Graphics/Color/Space/CIE1976/LAB.hs +++ b/Color/src/Graphics/Color/Space/CIE1976/LAB.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -25,6 +26,7 @@ module Graphics.Color.Space.CIE1976.LAB , LAB ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Space.Internal @@ -77,6 +79,14 @@ instance (Illuminant i, Elevator e) => Show (Color (LAB i) e) where -- | CIE1976 `LAB` color space instance (Illuminant i, Elevator e) => ColorModel (LAB i) e where type Components (LAB i) e = (e, e, e) + type ChannelCount (LAB i) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "L*" :| ["a*", "b*"] + channelColors _ = V3 0x80 0x80 0x80 :| -- gray + [ V3 0x00 0x64 0x00 -- dark green + , V3 0x00 0x00 0x8b -- dark blue + ] toComponents (ColorLAB l' a' b') = (l', a', b') {-# INLINE toComponents #-} fromComponents (l', a', b') = ColorLAB l' a' b' diff --git a/Color/src/Graphics/Color/Space/Internal.hs b/Color/src/Graphics/Color/Space/Internal.hs index a7b127d..7cc3500 100644 --- a/Color/src/Graphics/Color/Space/Internal.hs +++ b/Color/src/Graphics/Color/Space/Internal.hs @@ -65,15 +65,16 @@ module Graphics.Color.Space.Internal , module Graphics.Color.Model.X ) where +import Data.Coerce +import Data.Kind +import Data.List.NonEmpty +import Data.Typeable import Foreign.Storable +import GHC.TypeNats import Graphics.Color.Algebra.Binary import Graphics.Color.Algebra.Elevator import Graphics.Color.Model.Internal import Graphics.Color.Model.X -import Data.Typeable -import Data.Coerce -import GHC.TypeNats -import Data.Kind class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) => ColorSpace cs (i :: k) e | cs -> i where @@ -366,6 +367,11 @@ instance (Illuminant i, Elevator e) => Show (Color (XYZ (i :: k)) e) where -- | CIE1931 `XYZ` color space instance (Illuminant i, Elevator e) => ColorModel (XYZ (i :: k)) e where type Components (XYZ i) e = (e, e, e) + type ChannelCount (XYZ i) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "X" :| ["Y", "Z"] + channelColors _ = V3 0xff 0xff 0xff :| [V3 0x80 0x80 0x80, V3 0x2f 0x4f 0x4f] toComponents (ColorXYZ x y z) = (x, y, z) {-# INLINE toComponents #-} fromComponents (x, y, z) = ColorXYZ x y z @@ -442,6 +448,11 @@ instance (Illuminant i, Elevator e) => Show (Color (CIExyY (i :: k)) e) where -- | CIE xyY color space instance (Illuminant i, Elevator e) => ColorModel (CIExyY (i :: k)) e where type Components (CIExyY i) e = (e, e) + type ChannelCount (CIExyY i) = 2 + channelCount _ = 2 + {-# INLINE channelCount #-} + channelNames _ = "x" :| ["y"] + channelColors _ = V3 0xbd 0xb7 0x6b :| [V3 0xf0 0xe6 0x8c] toComponents (CIExyY (V2 x y)) = (x, y) {-# INLINE toComponents #-} fromComponents (x, y) = CIExyY (V2 x y) @@ -523,6 +534,11 @@ instance (Illuminant i, Elevator e) => Show (Color (Y i) e) where -- | `Y` - relative luminance of a color space instance (Illuminant i, Elevator e) => ColorModel (Y i) e where type Components (Y i) e = e + type ChannelCount (Y i) = 1 + channelCount _ = 1 + {-# INLINE channelCount #-} + channelNames _ = "Luminance" :| [] + channelColors _ = V3 0x80 0x80 0x80 :| [] toComponents = coerce {-# INLINE toComponents #-} fromComponents = coerce diff --git a/Color/src/Graphics/Color/Space/RGB/AdobeRGB.hs b/Color/src/Graphics/Color/Space/RGB/AdobeRGB.hs index cbb0f8d..cb410f3 100644 --- a/Color/src/Graphics/Color/Space/RGB/AdobeRGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/AdobeRGB.hs @@ -7,6 +7,7 @@ {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -- | @@ -112,6 +113,11 @@ instance (Typeable l, Elevator e) => Show (Color (AdobeRGB l) e) where -- | `AdobeRGB` color space instance (Typeable l, Elevator e) => ColorModel (AdobeRGB l) e where type Components (AdobeRGB l) e = (e, e, e) + type ChannelCount (AdobeRGB l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs index 9e808ed..f456280 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs @@ -78,6 +78,11 @@ pattern ColorCMYKA c m y k a = Alpha (CMYK (CM.ColorCMYK c m y k)) a -- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space instance ColorModel cs e => ColorModel (CMYK cs) e where type Components (CMYK cs) e = (e, e, e, e) + type ChannelCount (CMYK cs) = 4 + channelCount _ = 4 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.CMYK e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.CMYK e)) toComponents = toComponents . coerce {-# INLINE toComponents #-} fromComponents = coerce . fromComponents diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/HSI.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/HSI.hs index d558643..c1d859f 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/HSI.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/HSI.hs @@ -83,8 +83,12 @@ pattern ColorH360SI h s i <- ColorHSI ((* 360) -> h) s i where -- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space instance ColorModel cs e => ColorModel (HSI cs) e where type Components (HSI cs) e = (e, e, e) - toComponents = - toComponents . (coerce :: Color (HSI cs) e -> Color CM.HSI e) + type ChannelCount (HSI cs) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.HSI e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.HSI e)) + toComponents = toComponents . (coerce :: Color (HSI cs) e -> Color CM.HSI e) {-# INLINE toComponents #-} fromComponents = (coerce :: Color CM.HSI e -> Color (HSI cs) e) . fromComponents {-# INLINE fromComponents #-} diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/HSL.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/HSL.hs index f0f1a46..5b1368e 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/HSL.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/HSL.hs @@ -82,8 +82,12 @@ pattern ColorH360SL h s i <- ColorHSL ((* 360) -> h) s i where -- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space instance ColorModel cs e => ColorModel (HSL cs) e where type Components (HSL cs) e = (e, e, e) - toComponents = - toComponents . (coerce :: Color (HSL cs) e -> Color CM.HSL e) + type ChannelCount (HSL cs) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.HSL e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.HSL e)) + toComponents = toComponents . (coerce :: Color (HSL cs) e -> Color CM.HSL e) {-# INLINE toComponents #-} fromComponents = (coerce :: Color CM.HSL e -> Color (HSL cs) e) . fromComponents {-# INLINE fromComponents #-} diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/HSV.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/HSV.hs index 3b864bd..e52edf8 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/HSV.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/HSV.hs @@ -82,8 +82,12 @@ pattern ColorH360SV h s i <- ColorHSV ((* 360) -> h) s i where -- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space instance ColorModel cs e => ColorModel (HSV cs) e where type Components (HSV cs) e = (e, e, e) - toComponents = - toComponents . (coerce :: Color (HSV cs) e -> Color CM.HSV e) + type ChannelCount (HSV cs) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.HSV e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.HSV e)) + toComponents = toComponents . (coerce :: Color (HSV cs) e -> Color CM.HSV e) {-# INLINE toComponents #-} fromComponents = (coerce :: Color CM.HSV e -> Color (HSV cs) e) . fromComponents {-# INLINE fromComponents #-} diff --git a/Color/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs b/Color/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs index f195a2b..0a39eb8 100644 --- a/Color/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs +++ b/Color/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs @@ -76,6 +76,11 @@ pattern ColorY'CbCrA y cb cr a = Alpha (Y'CbCr (CM.ColorYCbCr y cb cr)) a instance (Typeable cs, ColorModel (cs 'NonLinear) e, Elevator e) => ColorModel (Y'CbCr cs) e where type Components (Y'CbCr cs) e = (e, e, e) + type ChannelCount (Y'CbCr cs) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.YCbCr e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.YCbCr e)) toComponents (ColorY'CbCr y cb cr) = (y, cb, cr) {-# INLINE toComponents #-} fromComponents (y, cb, cr) = ColorY'CbCr y cb cr diff --git a/Color/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs b/Color/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs index f8d6460..f7ffa45 100644 --- a/Color/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs @@ -58,6 +58,11 @@ instance (Typeable l, Illuminant i, Elevator e) => Show (Color (AdobeRGB (i :: k -- | `AdobeRGB` color space (derived) instance (Typeable l, Illuminant i, Elevator e) => ColorModel (AdobeRGB (i :: k) l) e where type Components (AdobeRGB i l) e = (e, e, e) + type ChannelCount (AdobeRGB i l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents diff --git a/Color/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs b/Color/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs index c848163..f6a483d 100644 --- a/Color/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs @@ -60,6 +60,11 @@ instance (Typeable l, Illuminant i, Elevator e) => Show (Color (CIERGB (i :: k) -- | `CIERGB` color space (derived) instance (Typeable l, Illuminant i, Elevator e) => ColorModel (CIERGB (i :: k) l) e where type Components (CIERGB i l) e = (e, e, e) + type ChannelCount (CIERGB i l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents diff --git a/Color/src/Graphics/Color/Space/RGB/Derived/SRGB.hs b/Color/src/Graphics/Color/Space/RGB/Derived/SRGB.hs index 539d680..cd6f302 100644 --- a/Color/src/Graphics/Color/Space/RGB/Derived/SRGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/Derived/SRGB.hs @@ -60,6 +60,11 @@ instance (Typeable l, Illuminant i, Elevator e) => Show (Color (SRGB (i :: k) l) -- | `SRGB` color space (derived) instance (Typeable l, Illuminant i, Elevator e) => ColorModel (SRGB (i :: k) l) e where type Components (SRGB i l) e = (e, e, e) + type ChannelCount (SRGB i l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents diff --git a/Color/src/Graphics/Color/Space/RGB/ITU/Rec470.hs b/Color/src/Graphics/Color/Space/RGB/ITU/Rec470.hs index b1ebf03..45b6df9 100644 --- a/Color/src/Graphics/Color/Space/RGB/ITU/Rec470.hs +++ b/Color/src/Graphics/Color/Space/RGB/ITU/Rec470.hs @@ -64,6 +64,11 @@ instance (Typeable l, Elevator e) => Show (Color (BT470_525 l) e) where -- | ITU-R BT.470 (525) color space instance (Typeable l, Elevator e) => ColorModel (BT470_525 l) e where type Components (BT470_525 l) e = (e, e, e) + type ChannelCount (BT470_525 l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents @@ -146,6 +151,11 @@ instance (Typeable l, Elevator e) => Show (Color (BT470_625 l) e) where -- | ITU-R BT.470 (625) color space instance (Typeable l, Elevator e) => ColorModel (BT470_625 l) e where type Components (BT470_625 l) e = (e, e, e) + type ChannelCount (BT470_625 l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents diff --git a/Color/src/Graphics/Color/Space/RGB/ITU/Rec601.hs b/Color/src/Graphics/Color/Space/RGB/ITU/Rec601.hs index 5b389b4..aa518e3 100644 --- a/Color/src/Graphics/Color/Space/RGB/ITU/Rec601.hs +++ b/Color/src/Graphics/Color/Space/RGB/ITU/Rec601.hs @@ -75,6 +75,11 @@ instance (Typeable l, Elevator e) => Show (Color (BT601_525 l) e) where -- | ITU-R BT.601 (525) color space instance (Typeable l, Elevator e) => ColorModel (BT601_525 l) e where type Components (BT601_525 l) e = (e, e, e) + type ChannelCount (BT601_525 l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents @@ -158,6 +163,11 @@ instance (Typeable l, Elevator e) => Show (Color (BT601_625 l) e) where -- | ITU-R BT.601 (625) color space instance (Typeable l, Elevator e) => ColorModel (BT601_625 l) e where type Components (BT601_625 l) e = (e, e, e) + type ChannelCount (BT601_625 l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents diff --git a/Color/src/Graphics/Color/Space/RGB/ITU/Rec709.hs b/Color/src/Graphics/Color/Space/RGB/ITU/Rec709.hs index f0e75a5..e9417f8 100644 --- a/Color/src/Graphics/Color/Space/RGB/ITU/Rec709.hs +++ b/Color/src/Graphics/Color/Space/RGB/ITU/Rec709.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -59,6 +60,11 @@ instance (Typeable l, Elevator e) => Show (Color (BT709 l) e) where -- | ITU-R BT.709 color space instance (Typeable l, Elevator e) => ColorModel (BT709 l) e where type Components (BT709 l) e = (e, e, e) + type ChannelCount (BT709 l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents diff --git a/Color/src/Graphics/Color/Space/RGB/Luma.hs b/Color/src/Graphics/Color/Space/RGB/Luma.hs index 2f8d220..2011b64 100644 --- a/Color/src/Graphics/Color/Space/RGB/Luma.hs +++ b/Color/src/Graphics/Color/Space/RGB/Luma.hs @@ -36,6 +36,7 @@ module Graphics.Color.Space.RGB.Luma import Data.Coerce import Data.Kind +import Data.List.NonEmpty import Data.Typeable import Foreign.Storable import Graphics.Color.Model.Internal @@ -92,6 +93,11 @@ instance (Typeable cs, Elevator e) => Show (Color (Y' cs) e) where -- | `Y'` - as a color model instance (Typeable cs, Elevator e) => ColorModel (Y' cs) e where type Components (Y' cs) e = e + type ChannelCount (Y' cs) = 1 + channelCount _ = 1 + {-# INLINE channelCount #-} + channelNames _ = "Luma" :| [] + channelColors _ = V3 0x80 0x80 0x80 :| [] toComponents (Y' y) = y {-# INLINE toComponents #-} fromComponents = Y' diff --git a/Color/src/Graphics/Color/Space/RGB/SRGB.hs b/Color/src/Graphics/Color/Space/RGB/SRGB.hs index 89b0384..a5e9efb 100644 --- a/Color/src/Graphics/Color/Space/RGB/SRGB.hs +++ b/Color/src/Graphics/Color/Space/RGB/SRGB.hs @@ -124,6 +124,11 @@ instance (Typeable l, Elevator e) => Show (Color (SRGB l) e) where -- | `SRGB` color space instance (Typeable l, Elevator e) => ColorModel (SRGB l) e where type Components (SRGB l) e = (e, e, e) + type ChannelCount (SRGB l) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = channelNames (Proxy :: Proxy (Color CM.RGB e)) + channelColors _ = channelColors (Proxy :: Proxy (Color CM.RGB e)) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents diff --git a/Color/src/Graphics/Pixel/ColorSpace.hs b/Color/src/Graphics/Pixel/ColorSpace.hs index 4df2305..d40eeae 100644 --- a/Color/src/Graphics/Pixel/ColorSpace.hs +++ b/Color/src/Graphics/Pixel/ColorSpace.hs @@ -15,7 +15,7 @@ -- Portability : non-portable -- module Graphics.Pixel.ColorSpace - ( Pixel(Pixel, PixelY, PixelXYZ, PixelLAB, PixelRGB, PixelHSI, PixelHSL, PixelHSV, + ( Pixel(Pixel, PixelX, PixelY, PixelXYZ, PixelLAB, PixelRGB, PixelHSI, PixelHSL, PixelHSV, PixelCMYK, PixelY'CbCr, PixelY', PixelYA, PixelXYZA, PixelLABA, PixelRGBA, PixelHSIA, PixelHSLA, PixelHSVA, PixelCMYKA, PixelY'CbCrA, PixelY'A) , liftPixel @@ -60,6 +60,7 @@ import Graphics.Color.Adaptation.VonKries import Graphics.Color.Algebra.Binary import qualified Graphics.Color.Model.RGB as CM import Graphics.Color.Space +import Graphics.Pixel (pattern PixelX) import Graphics.Pixel.Internal -- | Convert a pixel from one color space to any other. diff --git a/Color/tests/Graphics/Color/Model/Common.hs b/Color/tests/Graphics/Color/Model/Common.hs index 7d95e05..1e39af6 100644 --- a/Color/tests/Graphics/Color/Model/Common.hs +++ b/Color/tests/Graphics/Color/Model/Common.hs @@ -46,6 +46,7 @@ import Test.Hspec.QuickCheck import Test.HUnit (assertBool) import Test.Massiv.Array.Mutable import Test.QuickCheck +import GHC.TypeLits instance (Random e, ColorModel cs e, Arbitrary (Color cs e)) => Arbitrary (Color (Alpha cs) e) where arbitrary = addAlpha <$> arbitrary <*> arbitraryElevator @@ -218,6 +219,7 @@ colorModelSpec :: , Function (Components cs e) , CoArbitrary (Components cs e) , Arbitrary (Color cs e) + , KnownNat (ChannelCount cs) ) => String -> Spec @@ -225,6 +227,12 @@ colorModelSpec name = describe "ColorModel" $ do toFromComponentsSpec @cs @e it "Model Name" $ showsColorModelName (Proxy :: Proxy (Color cs e)) "" `shouldStartWith` name + it "ChannelCount" $ do + let px = Proxy :: Proxy (Color cs e) + count = channelCount px + count `shouldBe` fromInteger (natVal (Proxy :: Proxy (ChannelCount cs))) + length (channelNames px) `shouldBe` count + length (channelColors px) `shouldBe` count modifyMaxSuccess (`div` 10) $ describe "Array" $ do describe "Storable" $ mutableSpec @S @Ix1 @(Color cs e) From c616e507b7fd28a3af311a4fe45c262f9c26e4fa Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Mon, 16 Nov 2020 00:56:22 +0300 Subject: [PATCH 04/11] Remove `RealFloat` constraint from `ColorSpace` for Y --- Color/CHANGELOG.md | 1 + Color/src/Graphics/Color/Space/RGB/Luma.hs | 1 - 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/Color/CHANGELOG.md b/Color/CHANGELOG.md index f7967fd..29c27e7 100644 --- a/Color/CHANGELOG.md +++ b/Color/CHANGELOG.md @@ -4,6 +4,7 @@ * Addition of: `toGrayscale`, `applyGrayscale` and `replaceGrayscale`. * Addition of: `ChannelCount`, `channelCount`, `channelNames` and `channelColors` +* Remove `RealFloat` constraint from `ColorSpace` for `Y'` ## 0.3.3 diff --git a/Color/src/Graphics/Color/Space/RGB/Luma.hs b/Color/src/Graphics/Color/Space/RGB/Luma.hs index 2011b64..29aa81e 100644 --- a/Color/src/Graphics/Color/Space/RGB/Luma.hs +++ b/Color/src/Graphics/Color/Space/RGB/Luma.hs @@ -124,7 +124,6 @@ instance ( Typeable cs {-# INLINE applyGrayscale #-} replaceGrayscale _ = coerce {-# INLINE replaceGrayscale #-} - -- luminance = luminance . toBaseLinearSpace luminance = luminance . fmap (fromDouble :: Double -> e) . toBaseLinearSpace . fmap toDouble {-# INLINE luminance #-} toColorXYZ = toColorXYZ . fmap (fromDouble :: Double -> e) . toBaseLinearSpace . fmap toDouble From bd4876b72121638efff58e1c1988dbb9d46cbbfe Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Mon, 16 Nov 2020 03:24:55 +0300 Subject: [PATCH 05/11] Switch underlying representation of bit to maxBound instead of 1 --- Color/src/Graphics/Color/Algebra/Binary.hs | 58 ++++++++++------------ 1 file changed, 27 insertions(+), 31 deletions(-) diff --git a/Color/src/Graphics/Color/Algebra/Binary.hs b/Color/src/Graphics/Color/Algebra/Binary.hs index a4b4840..2d590f1 100644 --- a/Color/src/Graphics/Color/Algebra/Binary.hs +++ b/Color/src/Graphics/Color/Algebra/Binary.hs @@ -31,7 +31,7 @@ import qualified Data.Vector.Unboxed as U import Foreign.Storable import Graphics.Color.Algebra.Elevator import Prelude hiding (map) - +import Data.Coerce -- | Under the hood, binary pixels are backed by `Word8`, but can only take -- values of @0@ or @1@. Use `zero`\/`one` to construct a bit and `on`\/`off` to @@ -43,35 +43,32 @@ instance Show Bit where show (Bit 0) = "0" show _ = "1" +cf :: (Word8 -> Word8) -> Bit -> Bit +cf = coerce + +cf2 :: (Word8 -> Word8 -> Word8) -> Bit -> Bit -> Bit +cf2 = coerce instance Bits Bit where - (Bit 0) .&. _ = Bit 0 - (Bit 1) .&. (Bit 1) = Bit 1 - _ .&. (Bit 0) = Bit 0 - _ .&. _ = Bit 1 + (.&.) = cf2 (.&.) {-# INLINE (.&.) #-} - (Bit 1) .|. _ = Bit 1 - (Bit 0) .|. (Bit 0) = Bit 0 - _ .|. _ = Bit 1 + (.|.) = cf2 (.|.) {-# INLINE (.|.) #-} - (Bit 0) `xor` (Bit 0) = Bit 0 - (Bit 1) `xor` (Bit 1) = Bit 0 - _ `xor` _ = Bit 1 + xor = cf2 xor {-# INLINE xor #-} - complement (Bit 0) = Bit 1 - complement _ = Bit 0 + complement = cf complement {-# INLINE complement #-} shift !b 0 = b shift _ _ = Bit 0 {-# INLINE shift #-} rotate !b _ = b {-# INLINE rotate #-} - zeroBits = Bit 0 + zeroBits = zero {-# INLINE zeroBits #-} - bit 0 = Bit 1 - bit _ = Bit 0 + bit 0 = one + bit _ = zero {-# INLINE bit #-} - testBit (Bit 1) 0 = True + testBit (Bit b) 0 = b /= 0 testBit _ _ = False {-# INLINE testBit #-} bitSizeMaybe _ = Just 1 @@ -119,24 +116,23 @@ fromNum _ = one zero :: Bit -zero = Bit 0 +zero = coerce (0x00 :: Word8) {-# INLINE zero #-} one :: Bit -one = Bit 1 +one = coerce (0xff :: Word8) {-# INLINE one #-} -- | Values: @0@ and @1@ instance Elevator Bit where - minValue = Bit 0 + minValue = Bit 0x00 {-# INLINE minValue #-} - maxValue = Bit 1 + maxValue = Bit 0xff {-# INLINE maxValue #-} toShowS (Bit 0) = ('0':) toShowS _ = ('1':) - toWord8 (Bit 0) = 0 - toWord8 _ = maxBound + toWord8 = coerce {-# INLINE toWord8 #-} toWord16 (Bit 0) = 0 toWord16 _ = maxBound @@ -153,10 +149,10 @@ instance Elevator Bit where toRealFloat (Bit 0) = 0 toRealFloat _ = 1 {-# INLINE toRealFloat #-} - fromRealFloat 0 = Bit 0 - fromRealFloat _ = Bit 1 + fromRealFloat 0 = zero + fromRealFloat _ = one {-# INLINE fromRealFloat #-} - (//) (Bit x) (Bit y) = Bit (x `div` y) + (//) = cf2 div {-# INLINE (//) #-} @@ -167,9 +163,9 @@ instance Num Bit where -- 0 - 1 = 0 -- 1 - 0 = 1 -- 1 - 1 = 0 - (Bit 0) - (Bit 0) = Bit 0 - _ - (Bit 0) = Bit 1 - _ - _ = Bit 0 + (Bit 0) - (Bit 0) = zero + _ - (Bit 0) = one + _ - _ = zero {-# INLINE (-) #-} (*) = (.&.) {-# INLINE (*) #-} @@ -177,8 +173,8 @@ instance Num Bit where {-# INLINE abs #-} signum = id {-# INLINE signum #-} - fromInteger 0 = Bit 0 - fromInteger _ = Bit 1 + fromInteger 0 = zero + fromInteger _ = one {-# INLINE fromInteger #-} -- | Unboxing of a `Bit`. From 9c0f43451ec715c1b0b61681c7067ba764a21e5e Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Sat, 13 Mar 2021 03:03:27 +0300 Subject: [PATCH 06/11] Scale L*a*b* color space to [0, 1] range. Bump version to 0.4.0 --- Color/CHANGELOG.md | 5 +- Color/Color.cabal | 2 +- Color/src/Graphics/Color/Space.hs | 2 +- Color/src/Graphics/Color/Space/CIE1976/LAB.hs | 71 ++++++++++++++++--- Color/src/Graphics/Color/Standard/RAL.hs | 2 +- Color/tests/Graphics/Color/Model/Common.hs | 19 +++-- .../Graphics/Color/Space/CIE1976/LABSpec.hs | 5 +- 7 files changed, 84 insertions(+), 22 deletions(-) diff --git a/Color/CHANGELOG.md b/Color/CHANGELOG.md index 29c27e7..16351b0 100644 --- a/Color/CHANGELOG.md +++ b/Color/CHANGELOG.md @@ -1,9 +1,12 @@ # Changelog for Color -## 0.3.4 +## 0.4.0 +* Scale `L*a*b*` color space to `[0, 1]` range from the more common `[0, 100]` for + consistency. * Addition of: `toGrayscale`, `applyGrayscale` and `replaceGrayscale`. * Addition of: `ChannelCount`, `channelCount`, `channelNames` and `channelColors` + * Remove `RealFloat` constraint from `ColorSpace` for `Y'` ## 0.3.3 diff --git a/Color/Color.cabal b/Color/Color.cabal index 8504e9e..d36a6ba 100644 --- a/Color/Color.cabal +++ b/Color/Color.cabal @@ -1,5 +1,5 @@ name: Color -version: 0.3.4 +version: 0.4.0 synopsis: Color spaces and conversions between them description: Please see the README on GitHub at homepage: https://github.com/lehins/Color diff --git a/Color/src/Graphics/Color/Space.hs b/Color/src/Graphics/Color/Space.hs index e92b3fc..1efd90f 100644 --- a/Color/src/Graphics/Color/Space.hs +++ b/Color/src/Graphics/Color/Space.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Graphics.Color.Space --- Copyright : (c) Alexey Kuleshevich 2018-2020 +-- Copyright : (c) Alexey Kuleshevich 2018-2021 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/Color/src/Graphics/Color/Space/CIE1976/LAB.hs b/Color/src/Graphics/Color/Space/CIE1976/LAB.hs index f23e8a4..14e7aca 100644 --- a/Color/src/Graphics/Color/Space/CIE1976/LAB.hs +++ b/Color/src/Graphics/Color/Space/CIE1976/LAB.hs @@ -24,6 +24,13 @@ module Graphics.Color.Space.CIE1976.LAB , pattern ColorLAB , pattern ColorLABA , LAB + -- * Helpers + -- ** XYZ to L*a*b* + , xyz2lab + , ft + -- ** L*a*b* to XYZ + , lab2xyz + , ift ) where import Data.List.NonEmpty @@ -36,6 +43,52 @@ import Graphics.Color.Space.Internal -------------- -- | [CIE L*a*b*](https://en.wikipedia.org/wiki/CIELAB_color_space) color space +-- +-- It is customary to have CIELAB color channels to be in range of [0, 100], however in +-- this library all values for consistency are kept in a [0, 1] range for floating point +-- precision. +-- +-- Conversion from `XYZ` (`xyz2lab`): +-- +-- \[ +-- \begin{align} +-- L^\star &= 1.16 \ f\!\left(\frac{Y}{Y_{\mathrm{n}}}\right) - 0.16\\ +-- a^\star &= 5.0 \left(f\!\left(\frac{X}{X_{\mathrm{n}}}\right) - f\!\left(\frac{Y}{Y_{\mathrm{n}}}\right)\right)\\ +-- b^\star &= 2.0 \left(f\!\left(\frac{Y}{Y_{\mathrm{n}}}\right) - f\!\left(\frac{Z}{Z_{\mathrm{n}}}\right)\right) +-- \end{align} +-- \] +-- +-- Where `ft` is defined as: +-- +-- \[ +-- \begin{align} +-- f(t) &= \begin{cases} +-- \sqrt[3]{t} & \text{if } t > \delta^3 \\ +-- \dfrac{t}{3 \delta^2} + \frac{4}{29} & \text{otherwise} +-- \end{cases} \\ +-- \delta &= \tfrac{6}{29} +-- \end{align} +-- \] +-- +-- Conversion to `XYZ` (`lab2xyz`): +-- +-- \[ +-- \begin{align} +-- X &= X_{\mathrm{n}} f^{-1}\left(\frac{L^\star+0.16}{1.16} + \frac{a^\star}{5.0}\right)\\ +-- Y &= Y_{\mathrm{n}} f^{-1}\left(\frac{L^\star+0.16}{1.16}\right)\\ +-- Z &= Z_{\mathrm{n}} f^{-1}\left(\frac{L^\star+0.16}{1.16} - \frac{b^\star}{2.0}\right)\\ +-- \end{align} +-- \] +-- +-- Where `ift` is defined as: +-- +-- \[ +-- f^{-1}(t) = \begin{cases} +-- t^3 & \text{if } t > \delta \\ +-- 3\delta^2\left(t - \tfrac{4}{29}\right) & \text{otherwise} +-- \end{cases} +-- \] +-- data LAB (i :: k) -- | Color in CIE L*a*b* color space @@ -116,22 +169,22 @@ lab2xyz :: -> Color (XYZ i) a lab2xyz (ColorLAB l' a' b') = ColorXYZ x y z where - !(ColorXYZ wx _ wz) = whitePointTristimulus :: Color (XYZ i) a + ColorXYZ wx _ wz = whitePointTristimulus :: Color (XYZ i) a !l = scaleLightness l' - !x = wx * ift (l + toRealFloat a' / 500) + !x = wx * ift (l + toRealFloat a' / 5) !y = ift l - !z = wz * ift (l - toRealFloat b' / 200) + !z = wz * ift (l - toRealFloat b' / 2) {-# INLINE lab2xyz #-} scaleLightness :: (Elevator e, Elevator a, RealFloat a) => e -> a -scaleLightness l' = (toRealFloat l' + 16) / 116 +scaleLightness l' = (toRealFloat l' + 0.16) / 1.16 {-# INLINE scaleLightness #-} ift :: (Fractional a, Ord a) => a -> a ift t | t > 6 / 29 = t ^ (3 :: Int) | otherwise = (108 / 841) * (t - 4 / 29) - +{-# INLINE ift #-} xyz2lab :: @@ -140,13 +193,13 @@ xyz2lab :: -> Color (LAB i) e xyz2lab (ColorXYZ x y z) = ColorLAB l' a' b' where - !(ColorXYZ wx _ wz) = whitePointTristimulus :: Color (XYZ i) e + ColorXYZ wx _ wz = whitePointTristimulus :: Color (XYZ i) e !fx = ft (toRealFloat x / wx) !fy = ft (toRealFloat y) !fz = ft (toRealFloat z / wz) - !l' = 116 * fy - 16 - !a' = 500 * (fx - fy) - !b' = 200 * (fy - fz) + !l' = 1.16 * fy - 0.16 + !a' = 5 * (fx - fy) + !b' = 2 * (fy - fz) {-# INLINE xyz2lab #-} ft :: RealFloat a => a -> a diff --git a/Color/src/Graphics/Color/Standard/RAL.hs b/Color/src/Graphics/Color/Standard/RAL.hs index 2a70b46..cbf847e 100644 --- a/Color/src/Graphics/Color/Standard/RAL.hs +++ b/Color/src/Graphics/Color/Standard/RAL.hs @@ -475,7 +475,7 @@ greenBeige :: ColorSpace cs i e => Color cs e ral :: ColorSpace cs i e => Float -> Float -> Float -> Color cs e -ral l' a' b' = convert (ColorLAB l' a' b' :: Color (LAB D50) Float) +ral l' a' b' = convert (ColorLAB (l' / 100) (a' / 100) (b' / 100) :: Color (LAB D50) Float) greenBeige = ral 76.022 -0.366 27.636 beige = ral 73.595 5.518 26.95 diff --git a/Color/tests/Graphics/Color/Model/Common.hs b/Color/tests/Graphics/Color/Model/Common.hs index 1e39af6..6e602ee 100644 --- a/Color/tests/Graphics/Color/Model/Common.hs +++ b/Color/tests/Graphics/Color/Model/Common.hs @@ -69,7 +69,7 @@ matchListsWith f xs ys = do expectSameLength xs ys zipWithM_ f xs ys -expectSameLength :: Foldable t => t a1 -> t a2 -> IO () +expectSameLength :: (HasCallStack, Foldable t) => t a1 -> t a2 -> IO () expectSameLength xs ys = unless (length xs == length ys) $ expectationFailure $ "List lengths mismatch: " ++ show (length xs) ++ "/=" ++ show (length ys) @@ -155,7 +155,7 @@ epsilonColorIxSpec epsilon ix x y = epsilonEq :: - (Show a, RealFloat a) + (HasCallStack, Show a, RealFloat a) => a -- ^ Epsilon, a maximum tolerated error. Sign is ignored. -> a -- ^ Expected result. -> a -- ^ Tested value. @@ -163,7 +163,8 @@ epsilonEq :: epsilonEq epsilon x y = property $ epsilonExpect epsilon x y epsilonEqDouble :: - Double -- ^ Expected result. + HasCallStack + => Double -- ^ Expected result. -> Double -- ^ Tested value. -> Property epsilonEqDouble = epsilonEq epsilon @@ -179,22 +180,26 @@ epsilonEqFloat = epsilonEq epsilon epsilon = 1e-6 -epsilonEqColor :: (ColorModel cs e, RealFloat e) => Color cs e -> Color cs e -> Property +epsilonEqColor :: + (HasCallStack, ColorModel cs e, RealFloat e) => Color cs e -> Color cs e -> Property epsilonEqColor = epsilonEqColorTol epsilon where epsilon = 1e-11 -epsilonEqColorDouble :: ColorModel cs Double => Color cs Double -> Color cs Double -> Property +epsilonEqColorDouble :: + (HasCallStack, ColorModel cs Double) => Color cs Double -> Color cs Double -> Property epsilonEqColorDouble = epsilonEqColorTol epsilon where epsilon = 1e-12 -epsilonEqColorFloat :: ColorModel cs Float => Color cs Float -> Color cs Float -> Property +epsilonEqColorFloat :: + (HasCallStack, ColorModel cs Float) => Color cs Float -> Color cs Float -> Property epsilonEqColorFloat = epsilonEqColorTol epsilon where epsilon = 1e-6 -epsilonEqColorTol :: (ColorModel cs e, RealFloat e) => e -> Color cs e -> Color cs e -> Property +epsilonEqColorTol :: + (HasCallStack, ColorModel cs e, RealFloat e) => e -> Color cs e -> Color cs e -> Property epsilonEqColorTol epsilon x y = property $ epsilonColorExpect epsilon x y --conjoin $ F.toList $ liftA2 (epsilonEq epsilon) x y diff --git a/Color/tests/Graphics/Color/Space/CIE1976/LABSpec.hs b/Color/tests/Graphics/Color/Space/CIE1976/LABSpec.hs index 0de3608..3f55be0 100644 --- a/Color/tests/Graphics/Color/Space/CIE1976/LABSpec.hs +++ b/Color/tests/Graphics/Color/Space/CIE1976/LABSpec.hs @@ -24,11 +24,12 @@ spec = describe "LAB" $ do colorSpaceLenientSpec @(LAB 'D65) @Double 1e-10 describe "Same as colour package" $ do prop "lab2srgb" $ \lab@(ColorLAB l' a' b' :: Color (LAB 'W.D65) Double) -> - case Colour.toSRGB (Colour.cieLAB Colour.d65 l' a' b') of + case Colour.toSRGB (Colour.cieLAB Colour.d65 (l' * 100) (a' * 100) (b' * 100)) of Colour.RGB r g b -> (convertColor lab :: Color (D.SRGB 'W.D65 'NonLinear) Double) `epsilonEqColorDouble` ColorRGB r g b prop "srgb2xlab" $ \rgb@(ColorRGB r g b :: Color (D.SRGB 'W.D65 'NonLinear) Double) -> case Colour.cieLABView Colour.d65 (Colour.sRGB r g b) of (l', a', b') -> - convertColor rgb `epsilonEqColorDouble` (ColorLAB l' a' b' :: Color (LAB 'W.D65) Double) + convertColor rgb `epsilonEqColorDouble` + (ColorLAB (l' / 100) (a' / 100) (b' / 100) :: Color (LAB 'W.D65) Double) From 2a1e347aa20b9ccaa2fa6ecb097b179f91b03f2d Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Mon, 15 Mar 2021 19:16:15 +0300 Subject: [PATCH 07/11] Improve CI: * Use new version of git-modtime * Fixed caching on MacOS and Windows: * Disable caching of stack-work on MacOS, problems running cached binaries. * Add caching stack-root on Windows * Update to newer version of shc --- .github/workflows/haskell.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 914fff4..ed69bac 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -102,6 +102,7 @@ jobs: [ -n "${{ matrix.ghc }}" ] && [ "${{ matrix.os }}" == "ubuntu-latest" ] && STACK_ARGS="$STACK_ARGS --system-ghc" [ -n "${{ matrix.stack-yaml }}" ] && STACK_YAML=${{ matrix.stack-yaml }} stack $STACK_ARGS runghc git-modtime.hs + stack $STACK_ARGS path --stack-root --programs - name: Tests env: COVERALLS_TOKEN: ${{ secrets.COVERALLS_TOKEN }} From f9887192208500b96956240c236fe4ced3feb44b Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Thu, 6 May 2021 16:57:42 +0300 Subject: [PATCH 08/11] Update git-modtime --- .github/workflows/haskell.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index ed69bac..914fff4 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -102,7 +102,6 @@ jobs: [ -n "${{ matrix.ghc }}" ] && [ "${{ matrix.os }}" == "ubuntu-latest" ] && STACK_ARGS="$STACK_ARGS --system-ghc" [ -n "${{ matrix.stack-yaml }}" ] && STACK_YAML=${{ matrix.stack-yaml }} stack $STACK_ARGS runghc git-modtime.hs - stack $STACK_ARGS path --stack-root --programs - name: Tests env: COVERALLS_TOKEN: ${{ secrets.COVERALLS_TOKEN }} From 4cac25cd246ad92401d40cc7ca4928f04ad14bdb Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 19 Aug 2022 03:13:42 +0300 Subject: [PATCH 09/11] Finish implementation of missing class functions --- Color/src/Graphics/Color/Model/Internal.hs | 16 ++++++------ Color/src/Graphics/Color/Model/LCH.hs | 16 +++++++++--- .../Graphics/Color/Space/CIE1976/LAB/LCH.hs | 25 +++++++++++++++---- Color/src/Graphics/Color/Space/CIE1976/LUV.hs | 16 ++++++++++++ .../Graphics/Color/Space/CIE1976/LUV/LCH.hs | 23 ++++++++++++++--- Color/tests/Graphics/Color/Model/Common.hs | 4 +-- stack.yaml | 2 ++ 7 files changed, 80 insertions(+), 22 deletions(-) diff --git a/Color/src/Graphics/Color/Model/Internal.hs b/Color/src/Graphics/Color/Model/Internal.hs index 7744499..ef4da01 100644 --- a/Color/src/Graphics/Color/Model/Internal.hs +++ b/Color/src/Graphics/Color/Model/Internal.hs @@ -84,21 +84,21 @@ class ( Functor (Color cs) -- | Convert from an elemnt representation back to a Color. fromComponents :: Components cs e -> Color cs e - -- | Number of channels in the color model (eg. RGB has three). Must be a positive number. + -- | Number of channels in the color model (eg. RGB has three). -- - -- @since 0.3.1 - channelCount :: Proxy (Color cs e) -> Int + -- @since 0.4.0 + channelCount :: Proxy (Color cs e) -> Word8 -- | Textual name for each of the channels -- - -- @since 0.3.1 + -- @since 0.4.0 channelNames :: Proxy (Color cs e) -> NonEmpty String - -- | Some 8bit sRGB values for each of the channels that might or might not have some - -- meaningful relation to the actual colors in each channel. This is useful for plotting - -- values. + -- | Some non-white 8bit sRGB values for each of the channels that might or + -- might not have some meaningful visual relation to the actual channel + -- names. This is useful for plotting values. -- - -- @since 0.3.1 + -- @since 0.4.0 channelColors :: Proxy (Color cs e) -> NonEmpty (V3 Word8) -- | Display the @cs@ portion of the pixel. Color itself will not be evaluated. diff --git a/Color/src/Graphics/Color/Model/LCH.hs b/Color/src/Graphics/Color/Model/LCH.hs index 3f43479..af38af9 100644 --- a/Color/src/Graphics/Color/Model/LCH.hs +++ b/Color/src/Graphics/Color/Model/LCH.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -13,14 +14,15 @@ module Graphics.Color.Model.LCH -- * Constructors for an LCH color model. , pattern ColorLCH , pattern ColorLCHA - , Color + , Color(..) , ColorModel(..) , lch2lxy , lxy2lch ) where -import Data.Complex ( Complex(..), polar, mkPolar ) -import Data.Fixed ( mod' ) +import Data.Complex (Complex(..), polar, mkPolar) +import Data.Fixed (mod') +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal @@ -68,6 +70,14 @@ instance Elevator e => Show (Color LCH e) where -- | `LCH` color model instance Elevator e => ColorModel LCH e where type Components LCH e = (e, e, e) + type ChannelCount LCH = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "Luminance" :| ["Chroma", "Hue"] + channelColors _ = V3 0x80 0x80 0x80 :| + [ V3 0xff 0x00 0xff + , V3 0xcc 0xff 0x33 + ] toComponents (ColorLCH l c h) = (l, c, h) {-# INLINE toComponents #-} fromComponents (l, c, h) = ColorLCH l c h diff --git a/Color/src/Graphics/Color/Space/CIE1976/LAB/LCH.hs b/Color/src/Graphics/Color/Space/CIE1976/LAB/LCH.hs index 713bd1d..2f468a9 100644 --- a/Color/src/Graphics/Color/Space/CIE1976/LAB/LCH.hs +++ b/Color/src/Graphics/Color/Space/CIE1976/LAB/LCH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -5,10 +6,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: Graphics.Color.Space.CIE1976.LAB.LCH @@ -20,6 +22,7 @@ module Graphics.Color.Space.CIE1976.LAB.LCH , Color(LCHab) ) where +import Data.List.NonEmpty import Data.Coerce import Data.Proxy import Foreign.Storable @@ -73,9 +76,17 @@ pattern ColorLCHabA l c h a = Alpha (LCHab (CM.ColorLCH l c h)) a -- | CIE1976 `LCHab` color space instance (Illuminant i, Elevator e, ColorModel (LAB i) e) => ColorModel (LCHab i) e where type Components (LCHab i) e = (e, e, e) - toComponents = toComponents . coerce + type ChannelCount (LCHab i) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "L" :| ["Cab", "Hab"] + channelColors _ = V3 0x80 0x80 0x80 :| + [ V3 0x99 0xff 0x99 + , V3 0x66 0x66 0xff + ] + toComponents (LCHab lch) = toComponents lch {-# INLINE toComponents #-} - fromComponents = coerce . fromComponents + fromComponents = LCHab . fromComponents {-# INLINE fromComponents #-} showsColorModelName _ = ("LCH-"++) . showsColorModelName (Proxy :: Proxy (Color (LAB i) e)) @@ -83,9 +94,13 @@ instance (Illuminant i, Elevator e, ColorModel (LAB i) e) => ColorModel (LCHab i instance (Illuminant i, Elevator e, ColorSpace (LAB i) i e) => ColorSpace (LCHab i) i e where type BaseModel (LCHab i) = CM.LCH type BaseSpace (LCHab i) = LAB i - toBaseSpace = fmap fromDouble . fromComponents . CM.lch2lxy . fmap toDouble . coerce + toBaseSpace (LCHab lch) = fmap fromDouble . fromComponents . CM.lch2lxy . fmap toDouble $ lch {-# INLINE toBaseSpace #-} - fromBaseSpace = coerce . fmap fromDouble . CM.lxy2lch . toComponents . fmap toDouble + fromBaseSpace = LCHab . fmap fromDouble . CM.lxy2lch . toComponents . fmap toDouble {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 l _ _) = X l + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 _ c h) (X l) = coerce (V3 l c h) + {-# INLINE replaceGrayscale #-} diff --git a/Color/src/Graphics/Color/Space/CIE1976/LUV.hs b/Color/src/Graphics/Color/Space/CIE1976/LUV.hs index 5eeedce..63e2629 100644 --- a/Color/src/Graphics/Color/Space/CIE1976/LUV.hs +++ b/Color/src/Graphics/Color/Space/CIE1976/LUV.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -9,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Space.CIE1976.LUV -- @@ -20,6 +22,8 @@ module Graphics.Color.Space.CIE1976.LUV , LUV ) where +import Data.Coerce +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Space.Internal @@ -72,6 +76,14 @@ instance (Illuminant i, Elevator e) => Show (Color (LUV i) e) where -- | CIE1976 `LUV` color space instance (Illuminant i, Elevator e) => ColorModel (LUV i) e where type Components (LUV i) e = (e, e, e) + type ChannelCount (LUV i) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "L" :| ["U", "V"] + channelColors _ = V3 0x80 0x80 0x80 :| + [ V3 0x00 0xff 0xff + , V3 0x00 0x00 0x00 + ] toComponents (ColorLUV l' u' v') = (l', u', v') {-# INLINE toComponents #-} fromComponents (l', u', v') = ColorLUV l' u' v' @@ -86,6 +98,10 @@ instance (Illuminant i, Elevator e, RealFloat e) => ColorSpace (LUV (i :: k)) i {-# INLINE fromBaseSpace #-} luminance (ColorLUV l' _ _) = Y (ift (scaleLightness l')) {-# INLINE luminance #-} + grayscale (coerce -> V3 l _ _) = X l + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 _ c h) (X l) = coerce (V3 l c h) + {-# INLINE replaceGrayscale #-} toColorXYZ = luv2xyz {-# INLINE toColorXYZ #-} fromColorXYZ = xyz2luv diff --git a/Color/src/Graphics/Color/Space/CIE1976/LUV/LCH.hs b/Color/src/Graphics/Color/Space/CIE1976/LUV/LCH.hs index b5cc0de..e5e7bb5 100644 --- a/Color/src/Graphics/Color/Space/CIE1976/LUV/LCH.hs +++ b/Color/src/Graphics/Color/Space/CIE1976/LUV/LCH.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -9,6 +10,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module: Graphics.Color.Space.CIE1976.LUV.LCH @@ -20,6 +22,7 @@ module Graphics.Color.Space.CIE1976.LUV.LCH , Color(LCHuv) ) where +import Data.List.NonEmpty import Data.Coerce import Data.Proxy import Foreign.Storable @@ -73,9 +76,17 @@ pattern ColorLCHuvA l c h a = Alpha (LCHuv (CM.ColorLCH l c h)) a -- | CIE1976 `LCHuv` color space instance (Illuminant i, Elevator e, ColorModel (LUV i) e) => ColorModel (LCHuv i) e where type Components (LCHuv i) e = (e, e, e) - toComponents = toComponents . coerce + type ChannelCount (LCHuv i) = 3 + channelCount _ = 3 + {-# INLINE channelCount #-} + channelNames _ = "L" :| ["Cuv", "Huv"] + channelColors _ = V3 0x80 0x80 0x80 :| + [ V3 0x99 0x00 0x99 + , V3 0x99 0xcc 0x00 + ] + toComponents (LCHuv lch) = toComponents lch {-# INLINE toComponents #-} - fromComponents = coerce . fromComponents + fromComponents = LCHuv . fromComponents {-# INLINE fromComponents #-} showsColorModelName _ = ("LCH-"++) . showsColorModelName (Proxy :: Proxy (Color (LUV i) e)) @@ -83,9 +94,13 @@ instance (Illuminant i, Elevator e, ColorModel (LUV i) e) => ColorModel (LCHuv i instance (Illuminant i, Elevator e, ColorSpace (LUV i) i e) => ColorSpace (LCHuv i) i e where type BaseModel (LCHuv i) = CM.LCH type BaseSpace (LCHuv i) = LUV i - toBaseSpace = fmap fromDouble . fromComponents . CM.lch2lxy . fmap toDouble . coerce + toBaseSpace (LCHuv lch) = fmap fromDouble . fromComponents . CM.lch2lxy . fmap toDouble $ lch {-# INLINE toBaseSpace #-} - fromBaseSpace = coerce . fmap fromDouble . CM.lxy2lch . toComponents . fmap toDouble + fromBaseSpace = LCHuv . fmap fromDouble . CM.lxy2lch . toComponents . fmap toDouble {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} + grayscale (coerce -> V3 l _ _) = X l + {-# INLINE grayscale #-} + replaceGrayscale (coerce -> V3 _ c h) (X l) = coerce (V3 l c h) + {-# INLINE replaceGrayscale #-} diff --git a/Color/tests/Graphics/Color/Model/Common.hs b/Color/tests/Graphics/Color/Model/Common.hs index 6e602ee..6c0b763 100644 --- a/Color/tests/Graphics/Color/Model/Common.hs +++ b/Color/tests/Graphics/Color/Model/Common.hs @@ -236,8 +236,8 @@ colorModelSpec name = let px = Proxy :: Proxy (Color cs e) count = channelCount px count `shouldBe` fromInteger (natVal (Proxy :: Proxy (ChannelCount cs))) - length (channelNames px) `shouldBe` count - length (channelColors px) `shouldBe` count + length (channelNames px) `shouldBe` fromIntegral count + length (channelColors px) `shouldBe` fromIntegral count modifyMaxSuccess (`div` 10) $ describe "Array" $ do describe "Storable" $ mutableSpec @S @Ix1 @(Color cs e) diff --git a/stack.yaml b/stack.yaml index 92d2603..5e98552 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,3 +2,5 @@ resolver: lts-18.28 packages: - Color extra-deps: [] +nix: + packages: [zlib] From c9f0d6808a3ffd6474bb363184d273ef0d3504c3 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Sat, 20 Aug 2022 17:06:48 +0300 Subject: [PATCH 10/11] Add `channelRgbColors` --- Color/src/Graphics/Color/Model.hs | 11 +++++++++++ Color/src/Graphics/Color/Space/Internal.hs | 12 +++++++----- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/Color/src/Graphics/Color/Model.hs b/Color/src/Graphics/Color/Model.hs index 00a7d0b..1210429 100644 --- a/Color/src/Graphics/Color/Model.hs +++ b/Color/src/Graphics/Color/Model.hs @@ -8,6 +8,7 @@ -- module Graphics.Color.Model ( ColorModel(..) + , channelRgbColors -- * Alpha , Alpha , Opaque @@ -50,3 +51,13 @@ import Graphics.Color.Model.Internal import Graphics.Color.Model.RGB import Graphics.Color.Model.X import Graphics.Color.Model.YCbCr +import Data.Coerce +import Data.Proxy +import Data.List.NonEmpty + +-- | Uses `channelColors` to produce actual `RGB` colors for each +-- channel. Useful for plotting. +-- +-- @0.4.0 +channelRgbColors :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty (Color RGB Word8) +channelRgbColors = coerce . channelColors diff --git a/Color/src/Graphics/Color/Space/Internal.hs b/Color/src/Graphics/Color/Space/Internal.hs index 7cc3500..e180267 100644 --- a/Color/src/Graphics/Color/Space/Internal.hs +++ b/Color/src/Graphics/Color/Space/Internal.hs @@ -106,10 +106,12 @@ class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) => -- @since 0.1.0 luminance :: (Elevator a, RealFloat a) => Color cs e -> Color (Y i) a - -- | Drop chromatic information and get only the grayscale information from the - -- color. Without knowledge of the source color the produced value is inconsequential. + -- | Drop chromatic information and get only the grayscale information from + -- the color. Without knowledge of the source color the produced value is + -- inconsequential, becaus each class of color spaces has its own notion of + -- grayscale (luma, luminocity, in linear or non-linear form, etc.) -- - -- @since 0.3.1 + -- @since 0.4.0 grayscale :: Color cs e -> Color X e -- | Replace the grayscale information, leaving the chromatic portion of the coloer @@ -119,7 +121,7 @@ class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) => -- -- > replaceGrayscale c y = applyGrayscale c (const y) -- - -- @since 0.3.1 + -- @since 0.4.0 replaceGrayscale :: Color cs e -> Color X e -> Color cs e replaceGrayscale c y = applyGrayscale c (const y) {-# INLINE replaceGrayscale #-} @@ -132,7 +134,7 @@ class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) => -- -- > applyGrayscale c f = replaceGrayscale c (f (grayscale c)) -- - -- @since 0.3.1 + -- @since 0.4.0 applyGrayscale :: Color cs e -> (Color X e -> Color X e) -> Color cs e applyGrayscale c f = replaceGrayscale c (f (grayscale c)) {-# INLINE applyGrayscale #-} From d4b21ed9d51e293f6c7b74e74b6557afa8e683cb Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 23 Aug 2022 22:46:54 +0300 Subject: [PATCH 11/11] Remove restriction on SRB being NonLinear for Pixel --- Color/src/Graphics/Pixel/ColorSpace.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Color/src/Graphics/Pixel/ColorSpace.hs b/Color/src/Graphics/Pixel/ColorSpace.hs index d40eeae..2af61ef 100644 --- a/Color/src/Graphics/Pixel/ColorSpace.hs +++ b/Color/src/Graphics/Pixel/ColorSpace.hs @@ -84,14 +84,14 @@ convertPixel = liftPixel convert -- | Constructor for a pixel in @sRGB@ color space -- -- @since 0.1.0 -pattern PixelSRGB :: e -> e -> e -> Pixel (SRGB 'NonLinear) e +pattern PixelSRGB :: e -> e -> e -> Pixel (SRGB l) e pattern PixelSRGB r g b = Pixel (SRGB (CM.ColorRGB r g b)) {-# COMPLETE PixelSRGB #-} -- | Constructor for a pixel in @sRGB@ color space with Alpha channel -- -- @since 0.1.0 -pattern PixelSRGBA :: e -> e -> e -> e -> Pixel (Alpha (SRGB 'NonLinear)) e +pattern PixelSRGBA :: e -> e -> e -> e -> Pixel (Alpha (SRGB l)) e pattern PixelSRGBA r g b a = Pixel (Alpha (SRGB (CM.ColorRGB r g b)) a) {-# COMPLETE PixelSRGBA #-}