Color 0.3.3 → 0.4.0

raw patch · 65 files changed

+1290/−228 lines, 65 filesdep −doctestdep ~QuickCheckdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies removed: doctest

Dependency ranges changed: QuickCheck, base

API changes (from Hackage documentation)

- Graphics.Color.Adaptation: data family Adaptation t it ir e :: Type;

- Graphics.Color.Algebra.Binary: instance Data.Bits.Bits Graphics.Color.Algebra.Binary.Bit

- Graphics.Color.Space.RGB.Alternative.YCbCr: instance (Data.Typeable.Internal.Typeable cs, Graphics.Color.Model.Internal.ColorModel (cs 'Graphics.Color.Space.RGB.Internal.NonLinear) e, Graphics.Color.Algebra.Elevator.Elevator e) => GHC.Show.Show (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.RGB.Alternative.YCbCr.Y'CbCr cs) e)

- Graphics.Color.Space.RGB.Luma: instance forall k (cs :: Graphics.Color.Space.RGB.Internal.Linearity -> *) (i :: k) e. (Data.Typeable.Internal.Typeable cs, Graphics.Color.Space.Internal.Illuminant i, Graphics.Color.Space.Internal.ColorSpace (cs 'Graphics.Color.Space.RGB.Internal.Linear) i e, Graphics.Color.Space.Internal.ColorSpace (cs 'Graphics.Color.Space.RGB.Internal.NonLinear) i e, Graphics.Color.Space.RGB.Luma.Luma cs, Graphics.Color.Space.RGB.Internal.RedGreenBlue cs i) => Graphics.Color.Space.Internal.ColorSpace (Graphics.Color.Space.RGB.Luma.Y' cs) i e

+ Graphics.Color.Adaptation: data Adaptation t it ir e :: Type;

+ Graphics.Color.Algebra.Binary: instance GHC.Bits.Bits Graphics.Color.Algebra.Binary.Bit

+ Graphics.Color.Model: channelColors :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty (V3 Word8)

+ Graphics.Color.Model: channelCount :: ColorModel cs e => Proxy (Color cs e) -> Word8

+ Graphics.Color.Model: channelNames :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty String

+ Graphics.Color.Model: channelRgbColors :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty (Color RGB Word8)

+ Graphics.Color.Model: type ChannelCount cs :: Nat;

+ Graphics.Color.Model: type Components cs e :: Type;

+ Graphics.Color.Space: Weights :: V3 e -> Weights e

+ Graphics.Color.Space: [unWeights] :: Weights e -> V3 e

+ Graphics.Color.Space: applyGrayscale :: ColorSpace cs i e => Color cs e -> (Color X e -> Color X e) -> Color cs e

+ Graphics.Color.Space: channelColors :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty (V3 Word8)

+ Graphics.Color.Space: channelCount :: ColorModel cs e => Proxy (Color cs e) -> Word8

+ Graphics.Color.Space: channelNames :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty String

+ Graphics.Color.Space: data X

+ Graphics.Color.Space: grayscale :: ColorSpace cs i e => Color cs e -> Color X e

+ Graphics.Color.Space: newtype Weights e

+ Graphics.Color.Space: pattern ColorX :: e -> Color X e

+ Graphics.Color.Space: pattern ColorXA :: e -> e -> Color (Alpha X) e

+ Graphics.Color.Space: replaceGrayscale :: ColorSpace cs i e => Color cs e -> Color X e -> Color cs e

+ Graphics.Color.Space: rgb2y :: forall e e'. (Elevator e', Elevator e, RealFloat e) => Color RGB e' -> Weights e -> Color X e

+ Graphics.Color.Space: type BaseModel cs :: Type;

+ Graphics.Color.Space: type ChannelCount cs :: Nat;

+ Graphics.Color.Space: type Components cs e :: Type;

+ Graphics.Color.Space: type Temperature i :: n;

+ Graphics.Color.Space: unY :: Color (Y i) e -> e

+ Graphics.Color.Space.CIE1976.LAB: ft :: RealFloat a => a -> a

+ Graphics.Color.Space.CIE1976.LAB: ift :: (Fractional a, Ord a) => a -> a

+ Graphics.Color.Space.CIE1976.LAB: lab2xyz :: forall i a e. (Illuminant i, Elevator e, Elevator a, RealFloat a) => Color (LAB i) e -> Color (XYZ i) a

+ Graphics.Color.Space.CIE1976.LAB: xyz2lab :: forall i a e. (Illuminant i, Elevator a, Elevator e, RealFloat e) => Color (XYZ i) a -> Color (LAB i) e

+ Graphics.Color.Space.DIN99: data DIN99 (i :: k)

+ Graphics.Color.Space.DIN99: deltaE :: (Floating e, Illuminant i, Elevator e) => Color (LAB i) e -> Color (LAB i) e -> e

+ Graphics.Color.Space.DIN99: instance GHC.Classes.Eq Graphics.Color.Space.DIN99.DINMethod

+ Graphics.Color.Space.DIN99: instance GHC.Classes.Ord Graphics.Color.Space.DIN99.DINMethod

+ Graphics.Color.Space.DIN99: instance GHC.Enum.Bounded Graphics.Color.Space.DIN99.DINMethod

+ Graphics.Color.Space.DIN99: instance GHC.Enum.Enum Graphics.Color.Space.DIN99.DINMethod

+ Graphics.Color.Space.DIN99: instance GHC.Generics.Generic Graphics.Color.Space.DIN99.DINMethod

+ Graphics.Color.Space.DIN99: instance GHC.Read.Read Graphics.Color.Space.DIN99.DINMethod

+ Graphics.Color.Space.DIN99: instance GHC.Show.Show Graphics.Color.Space.DIN99.DINMethod

+ Graphics.Color.Space.DIN99: instance forall k (i :: k) e. (Graphics.Color.Space.Internal.Illuminant i, Graphics.Color.Algebra.Elevator.Elevator e) => GHC.Show.Show (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.DIN99.DIN99 i) e)

+ Graphics.Color.Space.DIN99: instance forall k (i :: k) e. (Graphics.Color.Space.Internal.Illuminant i, Graphics.Color.Algebra.Elevator.Elevator e) => Graphics.Color.Model.Internal.ColorModel (Graphics.Color.Space.DIN99.DIN99 i) e

+ Graphics.Color.Space.DIN99: instance forall k (i :: k) e. (Graphics.Color.Space.Internal.Illuminant i, Graphics.Color.Algebra.Elevator.Elevator e, GHC.Float.RealFloat e) => Graphics.Color.Space.Internal.ColorSpace (Graphics.Color.Space.DIN99.DIN99 i) i e

+ Graphics.Color.Space.DIN99: instance forall k (i :: k). Data.Foldable.Foldable (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.DIN99.DIN99 i))

+ Graphics.Color.Space.DIN99: instance forall k (i :: k). Data.Traversable.Traversable (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.DIN99.DIN99 i))

+ Graphics.Color.Space.DIN99: instance forall k (i :: k). GHC.Base.Applicative (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.DIN99.DIN99 i))

+ Graphics.Color.Space.DIN99: instance forall k (i :: k). GHC.Base.Functor (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.DIN99.DIN99 i))

+ Graphics.Color.Space.DIN99: instance forall k e (i :: k). Foreign.Storable.Storable e => Foreign.Storable.Storable (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.DIN99.DIN99 i) e)

+ Graphics.Color.Space.DIN99: instance forall k e (i :: k). GHC.Classes.Eq e => GHC.Classes.Eq (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.DIN99.DIN99 i) e)

+ Graphics.Color.Space.DIN99: instance forall k e (i :: k). GHC.Classes.Ord e => GHC.Classes.Ord (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.DIN99.DIN99 i) e)

+ Graphics.Color.Space.DIN99: pattern ColorDIN99 :: e -> e -> e -> Color (DIN99 i) e

+ Graphics.Color.Space.DIN99: pattern DIN99 :: () => V3 e -> Color (DIN99 i) e

+ Graphics.Color.Space.RGB: Weights :: V3 e -> Weights e

+ Graphics.Color.Space.RGB: [unWeights] :: Weights e -> V3 e

+ Graphics.Color.Space.RGB: applyGrayscale :: ColorSpace cs i e => Color cs e -> (Color X e -> Color X e) -> Color cs e

+ Graphics.Color.Space.RGB: channelColors :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty (V3 Word8)

+ Graphics.Color.Space.RGB: channelCount :: ColorModel cs e => Proxy (Color cs e) -> Word8

+ Graphics.Color.Space.RGB: channelNames :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty String

+ Graphics.Color.Space.RGB: data X

+ Graphics.Color.Space.RGB: grayscale :: ColorSpace cs i e => Color cs e -> Color X e

+ Graphics.Color.Space.RGB: newtype Weights e

+ Graphics.Color.Space.RGB: pattern ColorX :: e -> Color X e

+ Graphics.Color.Space.RGB: pattern ColorXA :: e -> e -> Color (Alpha X) e

+ Graphics.Color.Space.RGB: replaceGrayscale :: ColorSpace cs i e => Color cs e -> Color X e -> Color cs e

+ Graphics.Color.Space.RGB: rgb2y :: forall e e'. (Elevator e', Elevator e, RealFloat e) => Color RGB e' -> Weights e -> Color X e

+ Graphics.Color.Space.RGB: rgbLinearApplyGrayscale :: forall cs i e. ColorSpace (cs 'Linear) i e => Color (cs 'Linear) e -> (Color X e -> Color X e) -> Color (cs 'Linear) e

+ Graphics.Color.Space.RGB: rgbLinearGrayscale :: forall cs i e. ColorSpace (cs 'Linear) i e => Color (cs 'Linear) e -> Color X e

+ Graphics.Color.Space.RGB: 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

+ Graphics.Color.Space.RGB: rgbNonLinearGrayscale :: forall cs i e. (RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e) => Color (cs 'NonLinear) e -> Color X e

+ Graphics.Color.Space.RGB: type BaseModel cs :: Type;

+ Graphics.Color.Space.RGB: type ChannelCount cs :: Nat;

+ Graphics.Color.Space.RGB: type Components cs e :: Type;

+ Graphics.Color.Space.RGB: type Temperature i :: n;

+ Graphics.Color.Space.RGB: unY :: Color (Y i) e -> e

+ Graphics.Color.Space.RGB.Alternative: Weights :: V3 e -> Weights e

+ Graphics.Color.Space.RGB.Alternative: [unWeights] :: Weights e -> V3 e

+ Graphics.Color.Space.RGB.Alternative: applyGrayscale :: ColorSpace cs i e => Color cs e -> (Color X e -> Color X e) -> Color cs e

+ Graphics.Color.Space.RGB.Alternative: channelColors :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty (V3 Word8)

+ Graphics.Color.Space.RGB.Alternative: channelCount :: ColorModel cs e => Proxy (Color cs e) -> Word8

+ Graphics.Color.Space.RGB.Alternative: channelNames :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty String

+ Graphics.Color.Space.RGB.Alternative: data X

+ Graphics.Color.Space.RGB.Alternative: grayscale :: ColorSpace cs i e => Color cs e -> Color X e

+ Graphics.Color.Space.RGB.Alternative: newtype Weights e

+ Graphics.Color.Space.RGB.Alternative: pattern ColorX :: e -> Color X e

+ Graphics.Color.Space.RGB.Alternative: pattern ColorXA :: e -> e -> Color (Alpha X) e

+ Graphics.Color.Space.RGB.Alternative: replaceGrayscale :: ColorSpace cs i e => Color cs e -> Color X e -> Color cs e

+ Graphics.Color.Space.RGB.Alternative: rgb2y :: forall e e'. (Elevator e', Elevator e, RealFloat e) => Color RGB e' -> Weights e -> Color X e

+ Graphics.Color.Space.RGB.Alternative: rgbLinearApplyGrayscale :: forall cs i e. ColorSpace (cs 'Linear) i e => Color (cs 'Linear) e -> (Color X e -> Color X e) -> Color (cs 'Linear) e

+ Graphics.Color.Space.RGB.Alternative: rgbLinearGrayscale :: forall cs i e. ColorSpace (cs 'Linear) i e => Color (cs 'Linear) e -> Color X e

+ Graphics.Color.Space.RGB.Alternative: 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

+ Graphics.Color.Space.RGB.Alternative: rgbNonLinearGrayscale :: forall cs i e. (RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e) => Color (cs 'NonLinear) e -> Color X e

+ Graphics.Color.Space.RGB.Alternative: type BaseModel cs :: Type;

+ Graphics.Color.Space.RGB.Alternative: type ChannelCount cs :: Nat;

+ Graphics.Color.Space.RGB.Alternative: type Components cs e :: Type;

+ Graphics.Color.Space.RGB.Alternative: type Temperature i :: n;

+ Graphics.Color.Space.RGB.Alternative: unY :: Color (Y i) e -> e

+ Graphics.Color.Space.RGB.Alternative.YCbCr: instance (Data.Typeable.Internal.Typeable cs, Graphics.Color.Model.Internal.ColorModel (cs 'Graphics.Color.Space.RGB.Internal.NonLinear) e) => GHC.Show.Show (Graphics.Color.Model.Internal.Color (Graphics.Color.Space.RGB.Alternative.YCbCr.Y'CbCr cs) e)

+ Graphics.Color.Space.RGB.ITU.Rec601: 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

+ Graphics.Color.Space.RGB.ITU.Rec601: rec601ToYcbcr :: (RedGreenBlue cs i, RealFloat e) => Color (cs 'NonLinear) e -> Color YCbCr e

+ Graphics.Color.Space.RGB.ITU.Rec601: ycbcrToRec601 :: (RedGreenBlue cs i, RealFloat e) => Color YCbCr e -> Color (cs 'NonLinear) e

+ Graphics.Color.Space.RGB.Luma: instance forall k (cs :: Graphics.Color.Space.RGB.Internal.Linearity -> *) (i :: k) e. (Data.Typeable.Internal.Typeable cs, Graphics.Color.Space.Internal.ColorSpace (cs 'Graphics.Color.Space.RGB.Internal.Linear) i e, Graphics.Color.Space.Internal.ColorSpace (cs 'Graphics.Color.Space.RGB.Internal.NonLinear) i e, Graphics.Color.Space.RGB.Luma.Luma cs, Graphics.Color.Space.RGB.Internal.RedGreenBlue cs i) => Graphics.Color.Space.Internal.ColorSpace (Graphics.Color.Space.RGB.Luma.Y' cs) i e

+ Graphics.Pixel.ColorSpace: applyGrayscalePixel :: ColorSpace cs i e => Pixel cs e -> (Pixel X e -> Pixel X e) -> Pixel cs e

+ Graphics.Pixel.ColorSpace: grayscalePixel :: ColorSpace cs i e => Pixel cs e -> Pixel X e

+ Graphics.Pixel.ColorSpace: pattern PixelX :: e -> Pixel X e

+ Graphics.Pixel.ColorSpace: replaceGrayscalePixel :: ColorSpace cs i e => Pixel cs e -> Pixel X e -> Pixel cs e

- Graphics.Color.Model: type family Components cs e :: Type;

+ Graphics.Color.Model: type family Opaque cs

- Graphics.Color.Space: type family Temperature i :: n;

+ Graphics.Color.Space: type family Opaque cs

- Graphics.Color.Space.RGB: type family Temperature i :: n;

+ Graphics.Color.Space.RGB: type family Opaque cs

- Graphics.Color.Space.RGB.Alternative: type family Temperature i :: n;

+ Graphics.Color.Space.RGB.Alternative: type family Opaque cs

- Graphics.Pixel.ColorSpace: pattern PixelSRGB :: e -> e -> e -> Pixel (SRGB 'NonLinear) e

+ Graphics.Pixel.ColorSpace: pattern PixelSRGB :: forall e l. e -> e -> e -> Pixel (SRGB l) e

- Graphics.Pixel.ColorSpace: pattern PixelSRGBA :: e -> e -> e -> e -> Pixel (Alpha (SRGB 'NonLinear)) e

+ Graphics.Pixel.ColorSpace: pattern PixelSRGBA :: e -> e -> e -> e -> Pixel (Alpha (SRGB l)) e

Files

CHANGELOG.md +9/−0
Color.cabal +27/−25
LICENSE +1/−1
README.md +68/−0
bench/YCbCr.hs +71/−0
src/Graphics/Color/Adaptation.hs +1/−1
src/Graphics/Color/Adaptation/Internal.hs +2/−1
src/Graphics/Color/Adaptation/VonKries.hs +7/−1
src/Graphics/Color/Algebra.hs +4/−2
src/Graphics/Color/Algebra/Binary.hs +28/−32
src/Graphics/Color/Algebra/Elevator.hs +4/−2
src/Graphics/Color/Illuminant/CIE1931.hs +1/−1
src/Graphics/Color/Illuminant/CIE1964.hs +1/−1
src/Graphics/Color/Illuminant/ICC/PCS.hs +1/−1
src/Graphics/Color/Illuminant/ITU/Rec470.hs +1/−1
src/Graphics/Color/Illuminant/ITU/Rec601.hs +1/−1
src/Graphics/Color/Illuminant/Wikipedia.hs +1/−1
src/Graphics/Color/Model.hs +12/−1
src/Graphics/Color/Model/CMYK.hs +14/−4
src/Graphics/Color/Model/HSI.hs +9/−2
src/Graphics/Color/Model/HSL.hs +14/−5
src/Graphics/Color/Model/HSV.hs +17/−8
src/Graphics/Color/Model/Internal.hs +34/−8
src/Graphics/Color/Model/LCH.hs +13/−3
src/Graphics/Color/Model/RGB.hs +11/−1
src/Graphics/Color/Model/X.hs +8/−1
src/Graphics/Color/Model/YCbCr.hs +7/−1
src/Graphics/Color/Space.hs +1/−1
src/Graphics/Color/Space/CIE1931/RGB.hs +11/−2
src/Graphics/Color/Space/CIE1931/XYZ.hs +1/−1
src/Graphics/Color/Space/CIE1976/LAB.hs +77/−10
src/Graphics/Color/Space/CIE1976/LAB/LCH.hs +20/−5
src/Graphics/Color/Space/CIE1976/LUV.hs +16/−0
src/Graphics/Color/Space/CIE1976/LUV/LCH.hs +19/−4
src/Graphics/Color/Space/DIN99.hs +192/−0
src/Graphics/Color/Space/Internal.hs +99/−14
src/Graphics/Color/Space/RGB.hs +1/−1
src/Graphics/Color/Space/RGB/AdobeRGB.hs +15/−1
src/Graphics/Color/Space/RGB/Alternative.hs +1/−1
src/Graphics/Color/Space/RGB/Alternative/CMYK.hs +38/−1
src/Graphics/Color/Space/RGB/Alternative/HSI.hs +14/−5
src/Graphics/Color/Space/RGB/Alternative/HSL.hs +14/−5
src/Graphics/Color/Space/RGB/Alternative/HSV.hs +14/−5
src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs +30/−14
src/Graphics/Color/Space/RGB/CIERGB.hs +1/−1
src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs +14/−1
src/Graphics/Color/Space/RGB/Derived/CIERGB.hs +10/−1
src/Graphics/Color/Space/RGB/Derived/SRGB.hs +16/−2
src/Graphics/Color/Space/RGB/ITU/Rec470.hs +28/−1
src/Graphics/Color/Space/RGB/ITU/Rec601.hs +76/−1
src/Graphics/Color/Space/RGB/ITU/Rec709.hs +15/−1
src/Graphics/Color/Space/RGB/Internal.hs +43/−1
src/Graphics/Color/Space/RGB/Luma.hs +13/−2
src/Graphics/Color/Space/RGB/SRGB.hs +16/−1
src/Graphics/Color/Standard.hs +1/−1
src/Graphics/Color/Standard/Internal.hs +1/−1
src/Graphics/Color/Standard/RAL.hs +8/−2
src/Graphics/Color/Standard/SVG.hs +2/−2
src/Graphics/Pixel.hs +1/−1
src/Graphics/Pixel/ColorSpace.hs +36/−6
src/Graphics/Pixel/Internal.hs +1/−1
tests/Graphics/Color/Model/Common.hs +20/−7
tests/Graphics/Color/Space/CIE1976/LABSpec.hs +3/−2
tests/Graphics/Color/Space/Common.hs +55/−2
tests/doctests.hs +0/−16

CHANGELOG.md view

@@ -1,5 +1,14 @@ # Changelog for Color +## 0.4.0++* Addition of `DIN99` color space.+* 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  Addition of `SVG` colors

Color.cabal view

@@ -1,5 +1,5 @@ name:                Color-version:             0.3.3+version:             0.4.0 synopsis:            Color spaces and conversions between them description:         Please see the README on GitHub at <https://github.com/lehins/Color#readme> homepage:            https://github.com/lehins/Color@@ -7,11 +7,11 @@ license-file:        LICENSE author:              Alexey Kuleshevich maintainer:          alexey@kuleshevi.ch-copyright:           2019-2021 Alexey Kuleshevich+copyright:           2019-2025 Alexey Kuleshevich category:            Graphics extra-source-files:  README.md-                   , CHANGELOG.md-extra-doc-files:     files/*.svg+extra-doc-files:     CHANGELOG.md+                   , files/*.svg                    , files/svg/*.png cabal-version:       1.18 build-type:          Simple@@ -19,7 +19,13 @@                     , GHC == 8.6.5                     , GHC == 8.8.6                     , GHC == 8.10.7-                    , GHC == 9.0.1+                    , GHC == 9.0.2+                    , GHC == 9.2.8+                    , GHC == 9.4.8+                    , GHC == 9.6.6+                    , GHC == 9.8.4+                    , GHC == 9.10.1+                    , GHC == 9.12.1  library   hs-source-dirs:      src@@ -44,6 +50,7 @@                      , Graphics.Color.Space.CIE1976.LAB.LCH                      , Graphics.Color.Space.CIE1976.LUV                      , Graphics.Color.Space.CIE1976.LUV.LCH+                     , Graphics.Color.Space.DIN99                      , Graphics.Color.Space.RGB                      , Graphics.Color.Space.RGB.CIERGB                      , Graphics.Color.Space.RGB.AdobeRGB@@ -96,7 +103,8 @@   ghc-options:         -Wall                        -Wincomplete-record-updates                        -Wincomplete-uni-patterns-                       -Wredundant-constraints+  if impl(ghc < 9.0) || impl(ghc >= 9.6)+    ghc-options:   -Wredundant-constraints  test-suite tests   type:               exitcode-stdio-1.0@@ -159,25 +167,6 @@                       -threaded                       -freduction-depth=0 -test-suite doctests-  type:             exitcode-stdio-1.0-  hs-source-dirs:   tests-  main-is:          doctests.hs-  build-depends: base-  if impl(ghc >= 8.2) && impl(ghc < 8.10)-    build-depends: doctest >=0.16-                 , QuickCheck-                 , Color-                 , JuicyPixels-  default-language:    Haskell2010-  ghc-options:        -Wall-                      -Wincomplete-record-updates-                      -Wincomplete-uni-patterns-                      -Wredundant-constraints-                      -fno-warn-orphans-                      -threaded-- benchmark conversion   type:                exitcode-stdio-1.0   hs-source-dirs:      bench@@ -191,6 +180,19 @@                      , colour                      , deepseq                      , 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

LICENSE view

@@ -1,4 +1,4 @@-Copyright Alexey Kuleshevich (c) 2019-2020+Copyright Alexey Kuleshevich (c) 2019-2025  All rights reserved.

README.md view

@@ -38,6 +38,7 @@   * `Y'` - luma   * `CIE XYZ`   * `CIE L*a*b*`+  * `DIN99`   * `RGB`:      * `sRGB` - both standardized and derived@@ -72,6 +73,73 @@   * RAL   * SVG +## Example++Here is a short example how this library can be used. Here we assume a GHCi session that+can be started like so:++```shell+$ stack ghci --package Color+```++### Perceived lightness++Let's say we need find the perceived lightness as described in [this StackOverflow+answer](https://stackoverflow.com/questions/596216/formula-to-determine-perceived-brightness-of-rgb-color/56678483#56678483)+for an RGB triple `(128, 255, 65) :: (Word8, Word8, Word8)`.++Before we can attempt getting the lightness we need to do these two things:++1. Figure out what is the color space of the `RGB` triplet? In particular the `Illuminant`+   and the `Linearity` of the `RGB` color space.+2. Convert your `RGB` color to [`CIE+   L*a*b*`](https://en.wikipedia.org/wiki/CIELAB_color_space) and then we can get the `L*`+   out, which is the perceived lightness.++More often than not an RGB image will be encoded in non-linear sRGB color space with 8 bits+per channel, so we'll use that for this example:++```haskell+ghci> :set -XDataKinds+ghci> import Graphics.Color.Space+ghci> let rgb8 = ColorSRGB 128 255 65 :: Color (SRGB 'NonLinear) Word8+ghci> print rgb8+<SRGB 'NonLinear:(128,255, 65)>+```++Before we convert `sRGB` to `CIE L*a*b*` color space we need to increase the precision to+`Double`, because for now `Word8` is not supported by the `LAB` color space implementation:++```haskell+ghci> let rgb = toDouble <$> rgb8+ghci> print rgb+<SRGB 'NonLinear:( 0.5019607843137255, 1.0000000000000000, 0.2549019607843137)>+```++In order to convert to another color space without changing the `Illuminant` we can use+`convertColor` function. So here is how we convert to CIELAB and extract the perceived+lightness `L*`:++```haskell+ghci> let lab@(ColorLAB l _ _) = convertColor rgb :: Color (LAB D65) Double+ghci> lab+<LAB * D65:(90.0867507593648500,-65.7999116680496000,74.4643898323530600)>+ghci> l+90.08675075936485+```++### Color adaptation++When a change of `Illuminant` is also needed during color space conversion we can use+`convert` function++```haskell+ghci> import Graphics.Color.Adaptation (convert)+ghci> import qualified Graphics.Color.Illuminant.CIE1964 as CIE1964+ghci> let lab@(ColorLAB l _ _) = convert rgb :: Color (LAB 'CIE1964.D50) Double+ghci> lab+<LAB CIE1964 'D50:(90.2287735564601500,-59.3846969983265500,72.9304679742930800)>+```  ## External resources

+ bench/YCbCr.hs view

@@ -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)+        ]+    ]

src/Graphics/Color/Adaptation.hs view

@@ -1,6 +1,6 @@ -- | -- Module      : Graphics.Color.Adaptation--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Adaptation/Internal.hs view

@@ -4,9 +4,10 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} -- | -- Module      : Graphics.Color.Adaptation.Internal--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Adaptation/VonKries.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -5,10 +6,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+#if __GLASGOW_HASKELL__ >= 906+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+#else {-# LANGUAGE TypeInType #-}+#endif -- | -- Module      : Graphics.Color.Adaptation.VonKries--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Algebra.hs view

@@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module      : Graphics.Color.Algebra--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -33,9 +33,11 @@  import Data.Typeable import Foreign.Ptr-import Control.Applicative import Foreign.Storable import Graphics.Color.Algebra.Elevator+#if MIN_VERSION_base(4,10,0) && !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+#endif   --------

src/Graphics/Color/Algebra/Binary.hs view

@@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Algebra.Binary--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -31,7 +31,7 @@ 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 @@   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 @@   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 @@   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 @@   -- 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 @@   {-# INLINE abs #-}   signum      = id   {-# INLINE signum #-}-  fromInteger 0 = Bit 0-  fromInteger _ = Bit 1+  fromInteger 0 = zero+  fromInteger _ = one   {-# INLINE fromInteger #-}  -- | Unboxing of a `Bit`.

src/Graphics/Color/Algebra/Elevator.hs view

@@ -5,7 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module      : Graphics.Color.Algebra.Elevator--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -135,7 +135,9 @@  -- | Differs from `fromIntegral` due to: [GHC #17782](https://gitlab.haskell.org/ghc/ghc/issues/17782) ----- >>> fromIntegral (maxBound :: Word64) :: Double+-- This is the value for ghc < 9.2+--+-- > fromIntegral (maxBound :: Word64) :: Double -- 1.844674407370955e19 -- maxWord64 :: Double

src/Graphics/Color/Illuminant/CIE1931.hs view

@@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} -- | -- Module      : Graphics.Color.Illuminant.CIE1931--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Illuminant/CIE1964.hs view

@@ -3,7 +3,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Illuminant.CIE1964--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Illuminant/ICC/PCS.hs view

@@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} -- | -- Module      : Graphics.Color.Illuminant.ICC.PCS--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Illuminant/ITU/Rec470.hs view

@@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} -- | -- Module      : Graphics.Color.Illuminant.ITU.Rec470--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Illuminant/ITU/Rec601.hs view

@@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} -- | -- Module      : Graphics.Color.Illuminant.ITU.Rec601--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Illuminant/Wikipedia.hs view

@@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} -- | -- Module      : Graphics.Color.Illuminant.Wikipedia--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Model.hs view

@@ -1,6 +1,6 @@ -- | -- Module      : Graphics.Color.Model--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -8,6 +8,7 @@ -- module Graphics.Color.Model   ( ColorModel(..)+  , channelRgbColors   -- * Alpha   , Alpha   , Opaque@@ -50,3 +51,13 @@ 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

src/Graphics/Color/Model/CMYK.hs view

@@ -1,14 +1,15 @@-{-# 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--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -25,6 +26,7 @@   , rgb2cmyk   ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Model.RGB@@ -55,6 +57,14 @@ -- | `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 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

src/Graphics/Color/Model/HSI.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -11,7 +12,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Color.Model.HSI--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -23,12 +24,13 @@   , pattern ColorHSI   , pattern ColorHSIA   , pattern ColorH360SI-  , Color+  , Color(..)   , ColorModel(..)   , hsi2rgb   , rgb2hsi   ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Model.RGB@@ -85,6 +87,11 @@ -- | `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

src/Graphics/Color/Model/HSL.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -11,7 +12,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Color.Model.HSL--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -23,13 +24,14 @@   , pattern ColorHSL   , pattern ColorHSLA   , pattern ColorH360SL-  , Color+  , Color(..)   , ColorModel(..)   , hc2rgb   , hsl2rgb   , rgb2hsl   ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.HSV (hc2rgb) import Graphics.Color.Model.Internal@@ -86,6 +88,11 @@ -- | `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@@ -104,9 +111,11 @@   where     !max' = max r (max g b)     !min' = min r (min g b)-    !h' | max' == r = (    (g - b) / (max' - min')) / 6-        | max' == g = (2 + (b - r) / (max' - min')) / 6-        | max' == b = (4 + (r - g) / (max' - min')) / 6+    !c' = max' - min'+    !h' | c'   == 0 = 0+        | max' == r = (    (g - b) / c') / 6+        | max' == g = (2 + (b - r) / c') / 6+        | max' == b = (4 + (r - g) / c') / 6         | otherwise = 0     !h       | h' < 0 = h' + 1

src/Graphics/Color/Model/HSV.hs view

@@ -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 #-}@@ -11,7 +12,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Color.Model.HSV--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -23,13 +24,14 @@   , pattern ColorHSV   , pattern ColorHSVA   , pattern ColorH360SV-  , Color+  , Color(..)   , ColorModel(..)   , hc2rgb   , hsv2rgb   , rgb2hsv   ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Model.RGB@@ -85,6 +87,11 @@ -- | `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@@ -120,15 +127,17 @@   where     !max' = max r (max g b)     !min' = min r (min g b)-    !h' | max' == r = (    (g - b) / (max' - min')) / 6-        | max' == g = (2 + (b - r) / (max' - min')) / 6-        | max' == b = (4 + (r - g) / (max' - min')) / 6+    !c' = max' - min'+    !h' | c'   == 0 = 0+        | max' == r = (    (g - b) / c') / 6+        | max' == g = (2 + (b - r) / c') / 6+        | max' == b = (4 + (r - g) / c') / 6         | otherwise = 0     !h       | h' < 0 = h' + 1       | otherwise = h'     !s       | max' == 0 = 0-      | otherwise = (max' - min') / max'+      | otherwise = c' / max'     !v = max' {-# INLINE rgb2hsv #-}

src/Graphics/Color/Model/Internal.hs view

@@ -4,10 +4,11 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module      : Graphics.Color.Model.Internal--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -43,10 +44,11 @@   , VU.Vector(V_Color)   ) where -import Control.Applicative+import qualified Control.Applicative as A+import Data.List.NonEmpty as NE 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 @@       ) =>       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).+  --+  -- @since 0.4.0+  channelCount :: Proxy (Color cs e) -> Word8++  -- | Textual name for each of the channels+  --+  -- @since 0.4.0+  channelNames :: Proxy (Color cs e) -> NonEmpty String++  -- | 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.4.0+  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@@ -94,11 +114,11 @@   instance ColorModel cs e => Num (Color cs e) where-  (+)         = liftA2 (+)+  (+)         = A.liftA2 (+)   {-# INLINE (+) #-}-  (-)         = liftA2 (-)+  (-)         = A.liftA2 (-)   {-# INLINE (-) #-}-  (*)         = liftA2 (*)+  (*)         = A.liftA2 (*)   {-# INLINE (*) #-}   abs         = fmap abs   {-# INLINE abs #-}@@ -109,7 +129,7 @@   instance (ColorModel cs e, Fractional e) => Fractional (Color cs e) where-  (/)          = liftA2 (/)+  (/)          = A.liftA2 (/)   {-# INLINE (/) #-}   recip        = fmap recip   {-# INLINE recip #-}@@ -219,7 +239,7 @@   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 @@ 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

src/Graphics/Color/Model/LCH.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -13,14 +14,15 @@   -- * 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 @@ -- | `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

src/Graphics/Color/Model/RGB.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -10,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Model.RGB--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -26,6 +27,7 @@   , ColorModel(..)   ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Algebra import Graphics.Color.Model.Internal@@ -58,6 +60,14 @@ -- | `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

src/Graphics/Color/Model/X.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -9,7 +10,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Model.X--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -25,6 +26,7 @@   , rgb2y   ) where +import Data.List.NonEmpty import Data.Coerce import Foreign.Storable import Graphics.Color.Model.Internal@@ -65,6 +67,11 @@ -- | `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

src/Graphics/Color/Model/YCbCr.hs view

@@ -13,7 +13,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module      : Graphics.Color.Model.YCbCr--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -28,6 +28,7 @@   , ycbcr2rgb   ) where +import Data.List.NonEmpty import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Model.RGB@@ -72,6 +73,11 @@ -- | `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

src/Graphics/Color/Space.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module      : Graphics.Color.Space--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Space/CIE1931/RGB.hs view

@@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.CIE1931.RGB--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -60,6 +60,11 @@ -- | `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@@ -74,6 +79,10 @@   {-# 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 +103,4 @@ -- @since 0.2.0 castLinearity :: Color (CIERGB l') e -> Color (CIERGB l) e castLinearity = coerce-+{-# INLINE castLinearity #-}

src/Graphics/Color/Space/CIE1931/XYZ.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} -- | -- Module      : Graphics.Color.Space.CIE1931.XYZ--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Space/CIE1976/LAB.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -11,7 +12,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.CIE1976.LAB--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -23,8 +24,16 @@   , 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 import Foreign.Storable import Graphics.Color.Model.Internal import Graphics.Color.Space.Internal@@ -34,6 +43,52 @@ --------------  -- | [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@@ -77,6 +132,14 @@ -- | 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'@@ -91,6 +154,10 @@   {-# 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@@ -102,22 +169,22 @@   -> 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 ::@@ -126,13 +193,13 @@   -> 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

src/Graphics/Color/Space/CIE1976/LAB/LCH.hs view

@@ -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 @@   , Color(LCHab)   ) where +import Data.List.NonEmpty import Data.Coerce import Data.Proxy import Foreign.Storable@@ -73,9 +76,17 @@ -- | 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, 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 #-}

src/Graphics/Color/Space/CIE1976/LUV.hs view

@@ -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 @@   , 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 @@ -- | 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 @@   {-# 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

src/Graphics/Color/Space/CIE1976/LUV/LCH.hs view

@@ -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 @@   , Color(LCHuv)   ) where +import Data.List.NonEmpty import Data.Coerce import Data.Proxy import Foreign.Storable@@ -73,9 +76,17 @@ -- | 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, 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 #-}

+ src/Graphics/Color/Space/DIN99.hs view

@@ -0,0 +1,192 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeFamilies #-}++module Graphics.Color.Space.DIN99+  ( pattern DIN99,+    pattern ColorDIN99,+    DIN99,+    deltaE,+  )+where++import Data.List.NonEmpty+import Foreign.Storable+import GHC.Generics (Generic)+import Graphics.Color.Model.Internal+import Graphics.Color.Space.Internal+import Graphics.Color.Space.CIE1976.LAB++data DIN99 (i :: k)++-- | Color in DIN99 color space+newtype instance Color (DIN99 i) e = DIN99 (V3 e)++pattern ColorDIN99 :: e -> e -> e -> Color (DIN99 i) e+pattern ColorDIN99 l' a' b' = DIN99 (V3 l' a' b')++{-# COMPLETE ColorDIN99 #-}++-- | `DIN99` color space+deriving instance Eq e => Eq (Color (DIN99 i) e)++-- | `DIN99` color space+deriving instance Ord e => Ord (Color (DIN99 i) e)++-- | `DIN99` color space+deriving instance Functor (Color (DIN99 i))++-- | `DIN99` color space+deriving instance Applicative (Color (DIN99 i))++-- | `DIN99` color space+deriving instance Foldable (Color (DIN99 i))++-- | `DIN99` color space+deriving instance Traversable (Color (DIN99 i))++-- | `DIN99` color space+deriving instance Storable e => Storable (Color (DIN99 i) e)++-- | `DIN99` color space+instance (Illuminant i, Elevator e) => Show (Color (DIN99 i) e) where+  showsPrec _ = showsColorModel++instance (Illuminant i, Elevator e) => ColorModel (DIN99 i) e where+  type Components (DIN99 i) e = (e, e, e)+  type ChannelCount (DIN99 i) = 3+  channelCount _ = 3+  {-# INLINE channelCount #-}+  channelNames _ = "L*" :| ["a*", "b*"] -- DIN99 is base on Lab color space+  channelColors _ = V3 0x80 0x80 0x80 :| -- gray+                  [ V3 0x00 0x64 0x00    -- dark green+                  , V3 0x00 0x00 0x8b    -- dark blue+                  ]+  toComponents (ColorDIN99 l' a' b') = (l', a', b')+  {-# INLINE toComponents #-}+  fromComponents (l', a', b') = ColorDIN99 l' a' b'+  {-# INLINE fromComponents #-}++instance (Illuminant i, Elevator e, RealFloat e) => ColorSpace (DIN99 (i :: k)) i e where+  type BaseModel (DIN99 i) = DIN99 i+  type BaseSpace (DIN99 i) = DIN99 i+  toBaseSpace = id+  {-# INLINE toBaseSpace #-}+  fromBaseSpace = id+  {-# INLINE fromBaseSpace #-}+  luminance = luminance . dinToLAB DIN99Method+  {-# INLINE luminance #-}+  grayscale (ColorDIN99 l' _ _) = X l'+  {-# INLINE grayscale #-}+  replaceGrayscale (ColorDIN99 _ a' b') (X l') = ColorDIN99 l' a' b'+  {-# INLINE replaceGrayscale #-}+  toColorXYZ = toColorXYZ . dinToLAB DIN99Method+  {-# INLINE toColorXYZ #-}+  fromColorXYZ = labToDIN DIN99Method . fromColorXYZ+  {-# INLINE fromColorXYZ #-}++kE :: RealFloat a => a+kE = 1++kCH :: RealFloat a => a+kCH = 1++data DINMethod+  = ASTMD2244_07Method+  | DIN99Method+  | DIN99bMethod+  | DIN99cMethod+  | DIN99dMethod+  deriving (Eq, Show, Read, Ord, Bounded, Enum, Generic)++fromDINMethod ::+  ( Fractional a,+    Fractional b,+    Fractional c,+    Fractional d,+    Fractional f,+    Fractional g,+    Fractional h,+    Fractional e+  ) =>+  DINMethod ->+  (a, b, c, d, e, f, g, h)+fromDINMethod ASTMD2244_07Method =+  (105.509, 0.0158, 16.0, 0.7, 1, 9 / 200, 0.0, 9 / 200)+fromDINMethod DIN99Method = (105.509, 0.0158, 16.0, 0.7, 1, 9 / 200, 0.0, 9 / 200)+fromDINMethod DIN99bMethod = (303.67, 0.0039, 26.0, 0.83, 23.0, 0.075, 26.0, 1)+fromDINMethod DIN99cMethod = (317.65, 0.0037, 0.0, 0.94, 23.0, 0.066, 0.0, 1)+fromDINMethod DIN99dMethod = (325.22, 0.0036, 50.0, 1.14, 22.5, 0.06, 50.0, 1)++radians :: Floating a => a -> a+radians x = pi / 180 * x++-- | deltaE distance in DIN99 is the perceptually-uniform distance between+-- two points in the space. Otherwise known as euclidean distance.+deltaE ::+  (Floating e, Illuminant i, Elevator e) =>+  Color (LAB i) e ->+  Color (LAB i) e ->+  e+deltaE a b = sqrt $ sum ((a - b) ** 2)++-- | Bidirectional @DIN99@ @DIN99@ conversion as implemented in Python+-- [colour](https://github.com/colour-science/colour/blob/c3735e5d0ad67443022ece0b42b575e040eb61d1/colour/models/din99.py#L79) package.+--+-- >>> import Graphics.Color.Illuminant.Wikipedia as W+-- >>> labToDIN DIN99Method (ColorLAB 41.527874 52.638584 26.92318 :: Color (LAB 'W.D65) Float)+-- <DIN99 Degree2 'D65:(53.22821400,28.41634600, 3.89839500)>+-- >>> dinToLAB DIN99Method (ColorDIN99 53.228218 28.416348 3.8983955 :: Color (DIN99 'W.D65) Float)+-- <LAB Degree2 'D65:(41.52787800,52.63859000,26.92318300)>+labToDIN ::+  (RealFloat e) =>+  DINMethod ->+  Color (LAB i) e ->+  Color (DIN99 i) e+labToDIN m (ColorLAB l a b) = ColorDIN99 l_99 a_99 b_99+  where+    cos_c = cos $ radians c_3+    sin_c = sin $ radians c_3+    e = cos_c * a + sin_c * b+    f = c_4 * (- sin_c * a + cos_c * b)+    g' = sqrt (e ** 2 + f ** 2)+    h_ef = atan2 f e + radians c_7+    c_99 = c_5 * log (1 + c_6 * g') / (c_8 * kCH * kE)+    a_99 = c_99 * cos h_ef+    b_99 = c_99 * sin h_ef+    l_99 = c_1 * log (1 + c_2 * l) * kE+    (c_1, c_2, c_3, c_4, c_5, c_6, c_7, c_8) = fromDINMethod m++dinToLAB ::+  RealFloat e =>+  DINMethod ->+  Color (DIN99 i) e ->+  Color (LAB i) e+dinToLAB m (ColorDIN99 l_99 a_99 b_99) = ColorLAB l a b+  where+    expm1 x = exp x - 1+    cos' = cos (radians c_3)+    sin' = sin (radians c_3)++    h_99 = atan2 b_99 a_99 - radians c_7++    c_99 = sqrt (a_99 ** 2 + b_99 ** 2)+    g' = expm1 (c_8 / c_5 * c_99 * kCH * kE) / c_6++    e = g' * cos h_99+    f = g' * sin h_99++    a = e * cos' - f / c_4 * sin'+    b = e * sin' + f / c_4 * cos'+    l = expm1 (l_99 * kE / c_1) / c_2+    (c_1, c_2, c_3, c_4, c_5, c_6, c_7, c_8) = fromDINMethod m

src/Graphics/Color/Space/Internal.hs view

@@ -11,11 +11,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Color.Space.Internal--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -50,6 +51,7 @@   , whitePointTristimulus   , CCT(..)   , Y+  , unY   , pattern Y   , pattern YA   , XYZ@@ -61,20 +63,23 @@   , showsColorModel   , module Graphics.Color.Algebra.Binary   , module Graphics.Color.Algebra.Elevator+  , 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 qualified Graphics.Color.Model.X as CM-import Data.Typeable-import Data.Coerce-import GHC.TypeNats-import Data.Kind+import Graphics.Color.Model.X  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 +101,50 @@   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, becaus each class of color spaces has its own notion of+  -- grayscale (luma, luminocity, in linear or non-linear form, etc.)+  --+  -- /Warning/ - This method is still experimental. Use at your own risk.+  --+  -- @since 0.4.0+  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)+  --+  -- /Warning/ - This method is still experimental. Use at your own risk.+  --+  -- @since 0.4.0+  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.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 #-}++   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 +176,10 @@   {-# 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@@ -326,6 +374,11 @@ -- | 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@@ -340,6 +393,10 @@   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)@@ -398,6 +455,11 @@ -- | 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)@@ -405,7 +467,7 @@   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 +475,14 @@   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 +493,6 @@   {-# INLINE fromColorXYZ #-}  - ------------- --- Y --- -------------@@ -432,16 +501,21 @@ 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@@ -467,6 +541,11 @@ -- | `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@@ -475,16 +554,22 @@  -- | 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  #-}

src/Graphics/Color/Space/RGB.hs view

@@ -1,6 +1,6 @@ -- | -- Module      : Graphics.Color.Space.RGB--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Space/RGB/AdobeRGB.hs view

@@ -7,11 +7,12 @@ {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.RGB.AdobeRGB--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -112,6 +113,11 @@ -- | `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@@ -126,6 +132,10 @@   {-# 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 +150,10 @@   {-# 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

src/Graphics/Color/Space/RGB/Alternative.hs view

@@ -1,6 +1,6 @@ -- | -- Module      : Graphics.Color.Space.RGB.Alternative--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Space/RGB/Alternative/CMYK.hs view

@@ -12,7 +12,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module      : Graphics.Color.Space.RGB.Alternative.CMYK--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -78,6 +78,11 @@ -- | `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@@ -96,6 +101,10 @@   {-# INLINE fromBaseSpace #-}   luminance = luminance . toBaseSpace   {-# INLINE luminance #-}+  grayscale = grayscale . toBaseSpace+  {-# INLINE grayscale #-}+  applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f)+  {-# INLINE applyGrayscale #-}   @@ -109,6 +118,10 @@   {-# 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 +133,10 @@   {-# 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 +148,10 @@   {-# 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 +163,10 @@   {-# 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 +178,10 @@   {-# 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 +193,10 @@   {-# 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 +208,7 @@   {-# INLINE fromBaseSpace #-}   luminance = luminance . toBaseSpace   {-# INLINE luminance #-}+  grayscale = grayscale . toBaseSpace+  {-# INLINE grayscale #-}+  applyGrayscale c f = fromBaseSpace (applyGrayscale (toBaseSpace c) f)+  {-# INLINE applyGrayscale #-}

src/Graphics/Color/Space/RGB/Alternative/HSI.hs view

@@ -13,7 +13,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Color.Space.RGB.Alternative.HSI--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -83,9 +83,14 @@ -- | `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+  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 . fromComponents+  fromComponents = (coerce :: Color CM.HSI e -> Color (HSI cs) e) . fromComponents   {-# INLINE fromComponents #-}   showsColorModelName _ = ("HSI-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) @@ -94,9 +99,13 @@ 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 #-}

src/Graphics/Color/Space/RGB/Alternative/HSL.hs view

@@ -13,7 +13,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Color.Space.RGB.Alternative.HSL--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -82,9 +82,14 @@ -- | `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+  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 . fromComponents+  fromComponents = (coerce :: Color CM.HSL e -> Color (HSL cs) e) . fromComponents   {-# INLINE fromComponents #-}   showsColorModelName _ = ("HSL-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) @@ -93,9 +98,13 @@ 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 #-}

src/Graphics/Color/Space/RGB/Alternative/HSV.hs view

@@ -13,7 +13,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Color.Space.RGB.Alternative.HSV--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -82,9 +82,14 @@ -- | `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+  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 . fromComponents+  fromComponents = (coerce :: Color CM.HSV e -> Color (HSV cs) e) . fromComponents   {-# INLINE fromComponents #-}   showsColorModelName _ = ("HSV-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) @@ -93,9 +98,13 @@ 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 #-}

src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs view

@@ -11,9 +11,10 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Color.Space.RGB.Alternative.YCbCr--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -59,7 +60,7 @@ deriving instance Traversable (Color (Y'CbCr cs)) deriving instance Storable e => Storable (Color (Y'CbCr cs) e) -instance (Typeable cs, ColorModel (cs 'NonLinear) e, Elevator e) => Show (Color (Y'CbCr cs) e) where+instance (Typeable cs, ColorModel (cs 'NonLinear) e) => Show (Color (Y'CbCr cs) e) where   showsPrec _ = showsColorModel  -- | Constructor for an RGB color space in an alternative Y'CbCr color model@@ -75,6 +76,11 @@  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@@ -91,6 +97,10 @@   {-# 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 +111,10 @@   {-# 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 +125,10 @@   {-# 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 +139,10 @@   {-# 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 +154,10 @@   {-# 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 +165,7 @@ -- @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 +173,7 @@ -- @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`

src/Graphics/Color/Space/RGB/CIERGB.hs view

@@ -1,6 +1,6 @@ -- | -- Module      : Graphics.Color.Space.RGB.Derived.CIERGB--- Copyright   : (c) Alexey Kuleshevich 2020+-- Copyright   : (c) Alexey Kuleshevich 2020-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs view

@@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.RGB.Derived.AdobeRGB--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -58,6 +58,11 @@ -- | `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@@ -72,6 +77,10 @@   {-# 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 +95,10 @@   {-# 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

src/Graphics/Color/Space/RGB/Derived/CIERGB.hs view

@@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.RGB.Derived.CIERGB--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -60,6 +60,11 @@ -- | `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@@ -74,6 +79,10 @@   {-# 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)

src/Graphics/Color/Space/RGB/Derived/SRGB.hs view

@@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.RGB.Derived.SRGB--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -21,6 +21,7 @@   ( SRGB   ) where +import Data.Coerce import Data.Typeable import Foreign.Storable import Graphics.Color.Model.Internal@@ -29,7 +30,7 @@ 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)@@ -59,6 +60,11 @@ -- | `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@@ -73,6 +79,10 @@   {-# 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 +98,10 @@   {-# 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

src/Graphics/Color/Space/RGB/ITU/Rec470.hs view

@@ -6,11 +6,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.RGB.ITU.Rec470--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -63,6 +64,11 @@ -- | 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@@ -77,6 +83,10 @@   {-# 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 +101,10 @@   {-# 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@@ -137,6 +151,11 @@ -- | 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@@ -151,6 +170,10 @@   {-# 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 +188,10 @@   {-# 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

src/Graphics/Color/Space/RGB/ITU/Rec601.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}@@ -6,12 +7,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.RGB.ITU.Rec601--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -23,13 +25,18 @@   , 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)@@ -68,6 +75,11 @@ -- | 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@@ -82,6 +94,10 @@   {-# 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 +113,10 @@   {-# 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@@ -143,6 +163,11 @@ -- | 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@@ -157,6 +182,10 @@   {-# 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 +200,10 @@   {-# 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 +264,45 @@ 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 #-}

src/Graphics/Color/Space/RGB/ITU/Rec709.hs view

@@ -6,12 +6,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.RGB.ITU.Rec709--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -59,6 +60,11 @@ -- | 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@@ -73,6 +79,10 @@   {-# 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 +97,10 @@   {-# 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

src/Graphics/Color/Space/RGB/Internal.hs view

@@ -18,7 +18,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Color.Space.RGB.Internal--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -39,6 +39,10 @@   , xyz2rgbLinear   , rgbLuminance   , rgbLinearLuminance+  , rgbLinearGrayscale+  , rgbLinearApplyGrayscale+  , rgbNonLinearGrayscale+  , rgbNonLinearApplyGrayscale   , NPM(..)   , npmApply   , npmDerive@@ -219,6 +223,44 @@   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)

src/Graphics/Color/Space/RGB/Luma.hs view

@@ -14,7 +14,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module      : Graphics.Color.Space.RGB.Luma--- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- Copyright   : (c) Alexey Kuleshevich 2018-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -36,6 +36,7 @@  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 @@ -- | `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'@@ -99,7 +105,6 @@   instance ( Typeable cs-         , Illuminant i          , ColorSpace (cs 'Linear) i e          , ColorSpace (cs 'NonLinear) i e          , Luma cs@@ -112,6 +117,12 @@   {-# 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 . fmap (fromDouble :: Double -> e) . toBaseLinearSpace . fmap toDouble   {-# INLINE luminance #-}   toColorXYZ = toColorXYZ . fmap (fromDouble :: Double -> e) . toBaseLinearSpace . fmap toDouble

src/Graphics/Color/Space/RGB/SRGB.hs view

@@ -7,12 +7,13 @@ {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Color.Space.RGB.SRGB--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -36,6 +37,7 @@ 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 @@ -122,6 +124,11 @@ -- | `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@@ -136,6 +143,10 @@   {-# 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 +162,10 @@   {-# 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

src/Graphics/Color/Standard.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module      : Graphics.Color.Standard--- Copyright   : (c) Alexey Kuleshevich 2021+-- Copyright   : (c) Alexey Kuleshevich 2021-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Standard/Internal.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module      : Graphics.Color.Standard.Internal--- Copyright   : (c) Alexey Kuleshevich 2019-2021+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Color/Standard/RAL.hs view

@@ -1,13 +1,19 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+#if __GLASGOW_HASKELL__ >= 906+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+#else {-# LANGUAGE TypeInType #-}+#endif -- | -- Module      : Graphics.Color.Standard.RAL--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -475,7 +481,7 @@     :: 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

src/Graphics/Color/Standard/SVG.hs view

@@ -4,7 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module      : Graphics.Color.Standard.SVG--- Copyright   : (c) Alexey Kuleshevich 2021+-- Copyright   : (c) Alexey Kuleshevich 2021-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -26,7 +26,7 @@ -- >>> import Graphics.Color.Space.CIE1976.LAB -- >>> import Graphics.Color.Illuminant.CIE1931 -- >>> color (SVG :: SVG "aqua") :: Color (LAB 'D65) Float--- <LAB CIE1931 'D65:(91.11637000,-48.08154700,-14.12457300)>+-- <LAB CIE1931 'D65:( 0.91116370,-0.48081547,-0.14124572)> -- data SVG (n :: Symbol) = SVG

src/Graphics/Pixel.hs view

@@ -4,7 +4,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module      : Graphics.Pixel--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

src/Graphics/Pixel/ColorSpace.hs view

@@ -4,18 +4,19 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module      : Graphics.Pixel.ColorSpace--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental -- 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@@ -28,6 +29,10 @@   , fromPixelXYZ   , toPixelBaseSpace   , fromPixelBaseSpace+  -- * Grayscale+  , grayscalePixel+  , applyGrayscalePixel+  , replaceGrayscalePixel   -- ** Color model   , toPixelBaseModel   , fromPixelBaseModel@@ -56,13 +61,14 @@ 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. -- -- >>> :set -XDataKinds -- >>> :set -XTypeApplications--- >>> px = PixelSRGB @Float 0.0 0.5 1.0+-- >>> px = PixelSRGB @Float @'NonLinear 0.0 0.5 1.0 -- >>> px -- <SRGB 'NonLinear:( 0.00000000, 0.50000000, 1.00000000)> -- >>> convertPixel @(AdobeRGB 'NonLinear) @_ @Word8 px@@ -79,14 +85,14 @@ -- | Constructor for a pixel in @sRGB@ color space -- -- @since 0.1.0-pattern PixelSRGB :: e -> e -> e -> Pixel (SRGB 'NonLinear) e+pattern PixelSRGB :: forall e l. 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 #-} @@ -319,13 +325,37 @@ 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 ::      (ColorSpace cs i e, bcs ~ BaseSpace cs, ColorSpace bcs i e) => Pixel bcs e -> Pixel cs e 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

src/Graphics/Pixel/Internal.hs view

@@ -8,7 +8,7 @@ {-# OPTIONS_HADDOCK hide, not-home #-} -- | -- Module      : Graphics.Pixel.Internal--- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- Copyright   : (c) Alexey Kuleshevich 2019-2025 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental

tests/Graphics/Color/Model/Common.hs view

@@ -46,6 +46,7 @@ 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@@ -68,7 +69,7 @@   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)@@ -154,7 +155,7 @@   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.@@ -162,7 +163,8 @@ epsilonEq epsilon x y = property $ epsilonExpect epsilon x y  epsilonEqDouble ::-     Double -- ^ Expected result.+     HasCallStack+  => Double -- ^ Expected result.   -> Double -- ^ Tested value.   -> Property epsilonEqDouble = epsilonEq epsilon@@ -178,22 +180,26 @@     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 @@ -218,6 +224,7 @@      , Function (Components cs e)      , CoArbitrary (Components cs e)      , Arbitrary (Color cs e)+     , KnownNat (ChannelCount cs)      )   => String   -> Spec@@ -225,6 +232,12 @@   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` fromIntegral count+      length (channelColors px)  `shouldBe` fromIntegral count     modifyMaxSuccess (`div` 10) $ describe "Array" $ do       describe "Storable" $         mutableSpec @S @Ix1 @(Color cs e)

tests/Graphics/Color/Space/CIE1976/LABSpec.hs view

@@ -24,11 +24,12 @@   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)

tests/Graphics/Color/Space/Common.hs view

@@ -16,11 +16,15 @@   , 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 @@   -> 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 @@  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 @@   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

− tests/doctests.hs

@@ -1,16 +0,0 @@-{-# LANGUAGE CPP #-}-module Main where--#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ < 810--import Test.DocTest (doctest)--main :: IO ()-main = doctest ["src"]--#else--main :: IO ()-main = putStrLn "\nDoctests are not supported for older ghc version\n"--#endif