diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,15 @@ -# Changelog for color +# Changelog for Color + +## 0.2.0 + +* Add `Linearity` kind to `RedGreenBlue` color spaces. +* Add `Default` instance for `Pixel` +* Addition of universal division `(//)` to `Elevator` +* Addition of CIE1931 RGB color space. +* Fix show instance for floating point colors: adjust formatting in Elevator for `Float` and `Double` +* Add record accessor functions: `chromaticityCIExyY`, `whitePointChromaticity` +* Fix show instance for `Gamut` +* Remove deprecated: `CIECAM02` and `ciecam02Adaptation` ## 0.1.4 diff --git a/Color.cabal b/Color.cabal --- a/Color.cabal +++ b/Color.cabal @@ -1,5 +1,5 @@ name: Color -version: 0.1.4 +version: 0.2.0 synopsis: Color spaces and conversions between them description: Please see the README on GitHub at homepage: https://github.com/lehins/Color @@ -13,20 +13,13 @@ , CHANGELOG.md extra-doc-files: files/*.svg cabal-version: >=1.18 -build-type: Custom +build-type: Simple tested-with: GHC == 8.4.3 , GHC == 8.4.4 , GHC == 8.6.3 , GHC == 8.6.4 , GHC == 8.6.5 - , GHC == 8.8.1 - , GHC == 8.8.2 - -custom-setup - setup-depends: - base - , Cabal - , cabal-doctest >=1.0.6 + , GHC == 8.8.3 library hs-source-dirs: src @@ -45,23 +38,25 @@ , Graphics.Color.Illuminant.Wikipedia , Graphics.Color.Model , Graphics.Color.Space - -- , Graphics.Color.Space.CIE1931.RGB + , Graphics.Color.Space.CIE1931.RGB , Graphics.Color.Space.CIE1931.XYZ , Graphics.Color.Space.CIE1976.LAB -- , Graphics.Color.Space.CIE1976.LAB.LCH -- , Graphics.Color.Space.CIE1976.LAB.HLC -- , Graphics.Color.Space.CIE1976.LUV , Graphics.Color.Space.RGB - , Graphics.Color.Space.RGB.SRGB + , Graphics.Color.Space.RGB.CIERGB , Graphics.Color.Space.RGB.AdobeRGB + , Graphics.Color.Space.RGB.SRGB , Graphics.Color.Space.RGB.Alternative , Graphics.Color.Space.RGB.Alternative.CMYK , Graphics.Color.Space.RGB.Alternative.HSI , Graphics.Color.Space.RGB.Alternative.HSV , Graphics.Color.Space.RGB.Alternative.HSL , Graphics.Color.Space.RGB.Alternative.YCbCr - , Graphics.Color.Space.RGB.Derived.SRGB , Graphics.Color.Space.RGB.Derived.AdobeRGB + , Graphics.Color.Space.RGB.Derived.CIERGB + , Graphics.Color.Space.RGB.Derived.SRGB , Graphics.Color.Space.RGB.ITU.Rec470 , Graphics.Color.Space.RGB.ITU.Rec601 , Graphics.Color.Space.RGB.ITU.Rec709 @@ -116,10 +111,12 @@ , Graphics.Color.Model.RGBSpec , Graphics.Color.Model.YCbCrSpec , Graphics.Color.Space.Common + , Graphics.Color.Space.CIE1931.RGBSpec , Graphics.Color.Space.CIE1976.LABSpec , Graphics.Color.Space.RGB.AdobeRGBSpec , Graphics.Color.Space.RGB.SRGBSpec , Graphics.Color.Space.RGB.Derived.AdobeRGBSpec + , Graphics.Color.Space.RGB.Derived.CIERGBSpec , Graphics.Color.Space.RGB.Derived.SRGBSpec , Graphics.Color.Space.RGB.ITU.Rec470Spec , Graphics.Color.Space.RGB.ITU.Rec601Spec @@ -158,10 +155,9 @@ hs-source-dirs: tests main-is: doctests.hs build-depends: base - , doctest >=0.15 + , doctest >=0.16 , QuickCheck , Color - , template-haskell default-language: Haskell2010 ghc-options: -Wall -Wincomplete-record-updates diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,15 +1,19 @@ # Color -| Language | Travis | Coveralls |Gitter.im | -|:--------:|:------:|:---------:|:--------:| -| ![GitHub top language](https://img.shields.io/github/languages/top/lehins/Color.svg) | [![Travis](https://img.shields.io/travis/lehins/Color/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/lehins/Color) | [![Coverage Status](https://coveralls.io/repos/github/lehins/Color/badge.svg?branch=master)](https://coveralls.io/github/lehins/Color?branch=master) | [![Join the chat at https://gitter.im/haskell-massiv/Lobby](https://badges.gitter.im/haskell-massiv/Lobby.svg)](https://gitter.im/haskell-massiv/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) +A library for dealing with Colors and pixels. It implements arbitrary color space +conversion, chromatic adaptation and other color manipulations. +## Status + +| Language | Travis | Azure | Coveralls |Gitter.im | +|:--------:|:------:|:--------:|:---------:|:--------:| +| ![GitHub top language](https://img.shields.io/github/languages/top/lehins/Color.svg) | [![Travis](https://img.shields.io/travis/lehins/Color/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/lehins/Color) | [![Build Status](https://dev.azure.com/kuleshevich/Color/_apis/build/status/lehins.Color?branchName=master)](https://dev.azure.com/kuleshevich/Color/_build/latest?definitionId=1?branchName=master) | [![Coverage Status](https://coveralls.io/repos/github/lehins/Color/badge.svg?branch=master)](https://coveralls.io/github/lehins/Color?branch=master) | [![Join the chat at https://gitter.im/haskell-massiv/Lobby](https://badges.gitter.im/haskell-massiv/Lobby.svg)](https://gitter.im/haskell-massiv/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) + | Package | Hackage | Nightly | LTS | |:-------------------|:-------:|:-------:|:---:| | [`Color`](https://github.com/lehins/Color/tree/master/Color)| [![Hackage](https://img.shields.io/hackage/v/Color.svg)](https://hackage.haskell.org/package/Color)| [![Nightly](https://www.stackage.org/package/Color/badge/nightly)](https://www.stackage.org/nightly/package/Color)| [![Nightly](https://www.stackage.org/package/Color/badge/lts)](https://www.stackage.org/lts/package/Color)| -A library for dealing with Colors and pixels. It implements arbitrary color space -conversion, chromatic adaptation and other color manipulations. +## Description There is a clear separation between color models, color spaces and alternative representations of color spaces. All are distinct at the type level. The goal is to @@ -31,12 +35,13 @@ * Color spaces and arbitrary conversions between them: * `Y` - luminance + * `Y'` - luma * `CIE XYZ` * `CIE L*a*b*` * `RGB`: - * `sRGB` - * `AdobeRGB` + * `sRGB` - both standardized and derived + * `AdobeRGB` - both standardized and derived * ITU: `Rec470`, `Rec601` and `Rec709` * Alternative representations: @@ -56,17 +61,18 @@ * VonKries adaptation with transformations: - * VonKries - * Bradford (default) - * Fairchild - * CIECAM02 + * `VonKries` + * `Bradford` (default) + * `Fairchild` + * `CIECAM02` + * `CMCCAT2000` * Color Standards: * RAL -# External resources +## External resources * `Color` is on a list of curated [Awesome Colour](https://awesome-colour.org/#haskell) resources. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,34 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - import Distribution.Simple main :: IO () main = defaultMain - -#endif - diff --git a/bench/Conversion.hs b/bench/Conversion.hs --- a/bench/Conversion.hs +++ b/bench/Conversion.hs @@ -47,7 +47,7 @@ makeRandomRGB :: - (RedGreenBlue cs (i :: k), RandomGen g, Random a, Elevator a) => g -> (Color cs a, g) + (RedGreenBlue cs (i :: k), RandomGen g, Random a, Elevator a) => g -> (Color (cs 'NonLinear) a, g) makeRandomRGB gen = case randomV3 gen of (V3 r g b, gen') -> (mkColorRGB (CM.ColorRGB r g b), gen') @@ -69,8 +69,8 @@ -> g -> (Benchmark, g) mkBenchmarks _ tyName g0 = - let !(srgb :: Color SRGB f, g1) = makeRandomRGB g0 - !(srgbDerived :: Color (Derived.SRGB 'D65) f, g2) = makeRandomRGB g1 + let !(srgb :: Color (SRGB 'NonLinear) f, g1) = makeRandomRGB g0 + !(srgbDerived :: Color (Derived.SRGB 'D65 'NonLinear) f, g2) = makeRandomRGB g1 !(xyz :: Color (XYZ D65) f) = toColorXYZ srgb !(xyzDerived :: Color (XYZ 'D65) f) = toColorXYZ srgbDerived !(srgbColour :: Colour.Colour f, g3) = makeRandomColour g2 diff --git a/src/Graphics/Color/Adaptation/Internal.hs b/src/Graphics/Color/Adaptation/Internal.hs --- a/src/Graphics/Color/Adaptation/Internal.hs +++ b/src/Graphics/Color/Adaptation/Internal.hs @@ -52,8 +52,8 @@ chromaticAdaptation :: ChromaticAdaptation t it ir e => Adaptation t it ir e - -> Gamut cst it e - -> Gamut csr ir e + -> Gamut cs it e + -> Gamut cs ir e chromaticAdaptation adaptation g = Gamut redPrimary greenPrimary bluePrimary where applyMatrix primary = diff --git a/src/Graphics/Color/Adaptation/VonKries.hs b/src/Graphics/Color/Adaptation/VonKries.hs --- a/src/Graphics/Color/Adaptation/VonKries.hs +++ b/src/Graphics/Color/Adaptation/VonKries.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeInType #-} -- | -- Module : Graphics.Color.Adaptation.VonKries --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -33,9 +33,6 @@ , ciecat02Adaptation , cmccat2000Adaptation , adaptationMatrix - -- * Deprecated - , CIECAM02 - , ciecam02Adaptation ) where import Data.Coerce @@ -52,14 +49,14 @@ -- -- >>> cat :: CAT 'VonKries Float -- CAT VonKries 'VonKries Float - -- [ [ 0.400240, 0.707600,-0.080810 ] - -- , [-0.226300, 1.165320, 0.045700 ] - -- , [ 0.000000, 0.000000, 0.918220 ] ] + -- [ [ 0.40024000, 0.70760000,-0.08081000 ] + -- , [-0.22630000, 1.16532000, 0.04570000 ] + -- , [ 0.00000000, 0.00000000, 0.91822000 ] ] -- >>> icat :: ICAT 'VonKries Float -- ICAT VonKries 'VonKries Float - -- [ [ 1.859936,-1.129382, 0.219897 ] - -- , [ 0.361191, 0.638812,-0.000006 ] - -- , [-0.000000,-0.000000, 1.089064 ] ] + -- [ [ 1.85993650,-1.12938170, 0.21989742 ] + -- , [ 0.36119142, 0.63881250,-0.00000637 ] + -- , [-0.00000000,-0.00000000, 1.08906360 ] ] -- -- @since 0.1.0 | Bradford @@ -67,14 +64,14 @@ -- -- >>> cat :: CAT 'Bradford Float -- CAT VonKries 'Bradford Float - -- [ [ 0.895100, 0.266400,-0.161400 ] - -- , [-0.750200, 1.713500, 0.036700 ] - -- , [ 0.038900,-0.068500, 1.029600 ] ] + -- [ [ 0.89510000, 0.26640000,-0.16140000 ] + -- , [-0.75020000, 1.71350000, 0.03670000 ] + -- , [ 0.03890000,-0.06850000, 1.02960000 ] ] -- >>> icat :: ICAT 'Bradford Float -- ICAT VonKries 'Bradford Float - -- [ [ 0.986993,-0.147054, 0.159963 ] - -- , [ 0.432305, 0.518360, 0.049291 ] - -- , [-0.008529, 0.040043, 0.968487 ] ] + -- [ [ 0.98699290,-0.14705427, 0.15996265 ] + -- , [ 0.43230528, 0.51836026, 0.04929122 ] + -- , [-0.00852867, 0.04004282, 0.96848667 ] ] -- -- @since 0.1.0 | Fairchild @@ -82,14 +79,14 @@ -- -- >>> cat :: CAT 'Fairchild Float -- CAT VonKries 'Fairchild Float - -- [ [ 0.856200, 0.337200,-0.193400 ] - -- , [-0.836000, 1.832700, 0.003300 ] - -- , [ 0.035700,-0.046900, 1.011200 ] ] + -- [ [ 0.85620000, 0.33720000,-0.19340000 ] + -- , [-0.83600000, 1.83270000, 0.00330000 ] + -- , [ 0.03570000,-0.04690000, 1.01120000 ] ] -- >>> icat :: ICAT 'Fairchild Float -- ICAT VonKries 'Fairchild Float - -- [ [ 0.987400,-0.176825, 0.189425 ] - -- , [ 0.450435, 0.464933, 0.084632 ] - -- , [-0.013968, 0.027807, 0.986162 ] ] + -- [ [ 0.98739994,-0.17682500, 0.18942511 ] + -- , [ 0.45043513, 0.46493286, 0.08463200 ] + -- , [-0.01396833, 0.02780657, 0.98616177 ] ] -- -- @since 0.1.0 | CIECAT02 @@ -97,14 +94,14 @@ -- -- >>> cat :: CAT 'CIECAT02 Float -- CAT VonKries 'CIECAT02 Float - -- [ [ 0.732800, 0.429600,-0.162400 ] - -- , [-0.703600, 1.697500, 0.006100 ] - -- , [ 0.003000, 0.013600, 0.983400 ] ] + -- [ [ 0.73280000, 0.42960000,-0.16240000 ] + -- , [-0.70360000, 1.69750000, 0.00610000 ] + -- , [ 0.00300000, 0.01360000, 0.98340000 ] ] -- >>> icat :: ICAT 'CIECAT02 Float -- ICAT VonKries 'CIECAT02 Float - -- [ [ 1.096124,-0.278869, 0.182745 ] - -- , [ 0.454369, 0.473533, 0.072098 ] - -- , [-0.009628,-0.005698, 1.015326 ] ] + -- [ [ 1.09612380,-0.27886900, 0.18274519 ] + -- , [ 0.45436904, 0.47353318, 0.07209781 ] + -- , [-0.00962761,-0.00569803, 1.01532570 ] ] -- -- @since 0.1.3 | CMCCAT2000 @@ -112,14 +109,14 @@ -- -- >>> cat :: CAT 'CMCCAT2000 Float -- CAT VonKries 'CMCCAT2000 Float - -- [ [ 0.798200, 0.338900,-0.137100 ] - -- , [-0.591800, 1.551200, 0.040600 ] - -- , [ 0.000800, 0.023900, 0.975300 ] ] + -- [ [ 0.79820000, 0.33890000,-0.13710000 ] + -- , [-0.59180000, 1.55120000, 0.04060000 ] + -- , [ 0.00080000, 0.02390000, 0.97530000 ] ] -- >>> icat :: ICAT 'CMCCAT2000 Float -- ICAT VonKries 'CMCCAT2000 Float - -- [ [ 1.076450,-0.237662, 0.161212 ] - -- , [ 0.410964, 0.554342, 0.034694 ] - -- , [-0.010954,-0.013389, 1.024343 ] ] + -- [ [ 1.07645010,-0.23766239, 0.16121234 ] + -- , [ 0.41096430, 0.55434180, 0.03469386 ] + -- , [-0.01095376,-0.01338936, 1.02434310 ] ] -- -- @since 0.1.3 @@ -238,14 +235,6 @@ cmccat2000Adaptation :: ChromaticAdaptation 'CMCCAT2000 it ir e => Adaptation 'CIECAT02 it ir e cmccat2000Adaptation = adaptationMatrix {-# INLINE cmccat2000Adaptation #-} - -type CIECAM02 = 'CIECAT02 -{-# DEPRECATED CIECAM02 "In favor of a proper name 'CIECAT02'" #-} - -ciecam02Adaptation :: ChromaticAdaptation CIECAM02 it ir e => Adaptation CIECAM02 it ir e -ciecam02Adaptation = adaptationMatrix -{-# INLINE ciecam02Adaptation #-} -{-# DEPRECATED ciecam02Adaptation "In favor of a proper name 'ciecat02Adaptation'" #-} -- | This function allows conversion of a color between any two color spaces. It uses a -- very common `VonKries` chromatic adaptation transform with `Bradford` matrix. One of diff --git a/src/Graphics/Color/Algebra.hs b/src/Graphics/Color/Algebra.hs --- a/src/Graphics/Color/Algebra.hs +++ b/src/Graphics/Color/Algebra.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Graphics.Color.Algebra --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Algebra/Binary.hs b/src/Graphics/Color/Algebra/Binary.hs --- a/src/Graphics/Color/Algebra/Binary.hs +++ b/src/Graphics/Color/Algebra/Binary.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Algebra.Binary --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -29,7 +29,6 @@ import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Unboxed as U -import Data.Word (Word8) import Foreign.Storable import Graphics.Color.Algebra.Elevator import Prelude hiding (map) @@ -158,6 +157,8 @@ fromRealFloat 0 = Bit 0 fromRealFloat _ = Bit 1 {-# INLINE fromRealFloat #-} + (//) (Bit x) (Bit y) = Bit (x `div` y) + {-# INLINE (//) #-} instance Num Bit where diff --git a/src/Graphics/Color/Algebra/Elevator.hs b/src/Graphics/Color/Algebra/Elevator.hs --- a/src/Graphics/Color/Algebra/Elevator.hs +++ b/src/Graphics/Color/Algebra/Elevator.hs @@ -5,7 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Graphics.Color.Algebra.Elevator --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -26,6 +26,8 @@ import GHC.Float import Text.Printf +infixl 7 // + defFieldFormat :: FieldFormat defFieldFormat = FieldFormat Nothing Nothing Nothing Nothing False "" 'v' @@ -74,7 +76,10 @@ fromDouble :: Double -> e fromDouble = fromRealFloat + -- | Division that works for integral types as well as floating points. May throw an exception. + (//) :: e -> e -> e + -- | Lower the precision dropDown :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b dropDown !e = fromIntegral $ fromIntegral e `div` ((maxBound :: a) `div` @@ -112,8 +117,9 @@ {-# INLINE float2Word32 #-} -- | Same as: --- λ> fromIntegral (maxBound :: Word32) :: Float +-- >>> fromIntegral (maxBound :: Word32) :: Float -- 4.2949673e9 +-- maxWord32 :: Float maxWord32 = F# 4.2949673e9# {-# INLINE maxWord32 #-} @@ -127,10 +133,11 @@ d = maxWord64 * d' {-# INLINE double2Word64 #-} --- | Differs from `fromIntegral` due to: https://gitlab.haskell.org/ghc/ghc/issues/17782 +-- | Differs from `fromIntegral` due to: [GHC #17782](https://gitlab.haskell.org/ghc/ghc/issues/17782) -- --- λ> fromIntegral (maxBound :: Word64) :: Double +-- >>> fromIntegral (maxBound :: Word64) :: Double -- 1.844674407370955e19 +-- maxWord64 :: Double maxWord64 = D# 1.8446744073709552e19## {-# INLINE maxWord64 #-} @@ -165,6 +172,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = toWord8 {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0, 65535]]@ @@ -190,6 +199,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = toWord16 {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0, 4294967295]@ @@ -215,6 +226,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = toWord32 {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0, 18446744073709551615]@ @@ -240,6 +253,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = toWord64 {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0, 18446744073709551615]@ on 64bit instance Elevator Word where @@ -272,6 +287,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = stretch {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0, 127]@ instance Elevator Int8 where @@ -292,6 +309,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = stretch {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0, 32767]@ @@ -313,6 +332,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = stretch {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0, 2147483647]@ @@ -334,6 +355,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = stretch {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0, 9223372036854775807]@ @@ -355,6 +378,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = stretch {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0, 9223372036854775807]@ on 64bit @@ -382,13 +407,15 @@ {-# INLINE toRealFloat #-} fromRealFloat = stretch {-# INLINE fromRealFloat #-} + (//) = div + {-# INLINE (//) #-} -- | Values between @[0.0, 1.0]@ instance Elevator Float where maxValue = 1 minValue = 0 - fieldFormat _ = defFieldFormat { fmtWidth = Just 9, fmtPrecision = Just 6, fmtChar = 'f'} + fieldFormat _ = defFieldFormat { fmtWidth = Just 11, fmtPrecision = Just 8, fmtChar = 'f'} toWord8 = stretch {-# INLINE toWord8 #-} toWord16 = stretch @@ -407,13 +434,15 @@ {-# INLINE toRealFloat #-} fromRealFloat = uncurry encodeFloat . decodeFloat {-# INLINE fromRealFloat #-} + (//) = (/) + {-# INLINE (//) #-} -- | Values between @[0.0, 1.0]@ instance Elevator Double where maxValue = 1 minValue = 0 - fieldFormat _ = defFieldFormat { fmtWidth = Just 15, fmtPrecision = Just 12, fmtChar = 'f' } + fieldFormat _ = defFieldFormat { fmtWidth = Just 19, fmtPrecision = Just 16, fmtChar = 'f' } toWord8 = stretch {-# INLINE toWord8 #-} toWord16 = stretch @@ -432,6 +461,8 @@ {-# INLINE toRealFloat #-} fromRealFloat = uncurry encodeFloat . decodeFloat {-# INLINE fromRealFloat #-} + (//) = (/) + {-# INLINE (//) #-} {-# RULES "toRealFloat :: Double -> Double / Float -> Float" toRealFloat = id @@ -467,3 +498,5 @@ {-# INLINE toRealFloat #-} fromRealFloat = (:+ 0) . fromRealFloat {-# INLINE fromRealFloat #-} + (//) = (/) + {-# INLINE (//) #-} diff --git a/src/Graphics/Color/Illuminant/CIE1931.hs b/src/Graphics/Color/Illuminant/CIE1931.hs --- a/src/Graphics/Color/Illuminant/CIE1931.hs +++ b/src/Graphics/Color/Illuminant/CIE1931.hs @@ -89,7 +89,7 @@ whitePoint = WhitePoint 0.29903 0.31488 colorTemperature = rectifyColorTemperature 7500 1.4380 --- | @[x=1/3, y=1/3]@ - CIE 1931 2° Observer - +-- | @[x=1\/3, y=1\/3]@ - CIE 1931 2° Observer - -- /https://www.colour-science.org/ instance Illuminant 'E where type Temperature 'E = 5454 diff --git a/src/Graphics/Color/Illuminant/CIE1964.hs b/src/Graphics/Color/Illuminant/CIE1964.hs --- a/src/Graphics/Color/Illuminant/CIE1964.hs +++ b/src/Graphics/Color/Illuminant/CIE1964.hs @@ -71,7 +71,7 @@ whitePoint = WhitePoint 0.29968 0.31740 colorTemperature = I2.rectifyColorTemperature 7500 1.4380 --- | @[x=1/3, y=1/3]@ - CIE 1964 10° Observer - +-- | @[x=1\/3, y=1\/3]@ - CIE 1964 10° Observer - -- /https://www.colour-science.org/ instance Illuminant 'E where type Temperature 'E = 5454 diff --git a/src/Graphics/Color/Illuminant/ICC/PCS.hs b/src/Graphics/Color/Illuminant/ICC/PCS.hs --- a/src/Graphics/Color/Illuminant/ICC/PCS.hs +++ b/src/Graphics/Color/Illuminant/ICC/PCS.hs @@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} -- | -- Module : Graphics.Color.Illuminant.ICC.PCS --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -20,9 +20,9 @@ -- white point defined in ICC PCS. Useful for chromatic adaptation. -- -- >>> whitePoint :: WhitePoint D50 Double --- WhitePoint (Chromaticity ) +-- WhitePoint (Chromaticity {chromaticityCIExyY = }) -- >>> whitePointTristimulus :: Color (XYZ D50) Float --- +-- -- >>> colorTemperature :: CCT D50 -- CCT {unCCT = 5003.0} -- diff --git a/src/Graphics/Color/Illuminant/ITU/Rec470.hs b/src/Graphics/Color/Illuminant/ITU/Rec470.hs --- a/src/Graphics/Color/Illuminant/ITU/Rec470.hs +++ b/src/Graphics/Color/Illuminant/ITU/Rec470.hs @@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} -- | -- Module : Graphics.Color.Illuminant.ITU.Rec470 --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -24,9 +24,9 @@ -- declaration in here. -- -- >>> whitePoint :: WhitePoint C Float --- WhitePoint (Chromaticity ) +-- WhitePoint (Chromaticity {chromaticityCIExyY = }) -- >>> whitePointTristimulus :: Color (XYZ C) Float --- +-- -- >>> colorTemperature :: CCT C -- CCT {unCCT = 6774.0} -- @@ -47,9 +47,9 @@ -- declaration in here. -- -- >>> whitePoint :: WhitePoint D65 Float --- WhitePoint (Chromaticity ) +-- WhitePoint (Chromaticity {chromaticityCIExyY = }) -- >>> whitePointTristimulus :: Color (XYZ D65) Float --- +-- -- >>> colorTemperature :: CCT D65 -- CCT {unCCT = 6504.0} -- diff --git a/src/Graphics/Color/Illuminant/ITU/Rec601.hs b/src/Graphics/Color/Illuminant/ITU/Rec601.hs --- a/src/Graphics/Color/Illuminant/ITU/Rec601.hs +++ b/src/Graphics/Color/Illuminant/ITU/Rec601.hs @@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} -- | -- Module : Graphics.Color.Illuminant.ITU.Rec601 --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -22,9 +22,9 @@ -- `Graphics.Color.Illuminant.ITU.Rec470.D65` specified in Rec.470. -- -- >>> whitePoint :: WhitePoint D65 Float --- WhitePoint (Chromaticity ) +-- WhitePoint (Chromaticity {chromaticityCIExyY = }) -- >>> whitePointTristimulus :: Color (XYZ D65) Float --- +-- -- >>> colorTemperature :: CCT D65 -- CCT {unCCT = 6504.0} -- diff --git a/src/Graphics/Color/Illuminant/Wikipedia.hs b/src/Graphics/Color/Illuminant/Wikipedia.hs --- a/src/Graphics/Color/Illuminant/Wikipedia.hs +++ b/src/Graphics/Color/Illuminant/Wikipedia.hs @@ -51,7 +51,7 @@ type Temperature 'D75 = 7504 whitePoint = WhitePoint 0.29902 0.31485 --- | @[x=1/3, y=1/3]@ - 2° Observer - Wikipedia +-- | @[x=1\/3, y=1\/3]@ - 2° Observer - Wikipedia instance Illuminant 'E where type Temperature 'E = 5454 whitePoint = WhitePoint (1 / 3) (1 / 3) diff --git a/src/Graphics/Color/Model.hs b/src/Graphics/Color/Model.hs --- a/src/Graphics/Color/Model.hs +++ b/src/Graphics/Color/Model.hs @@ -1,6 +1,6 @@ -- | -- Module : Graphics.Color.Model --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -40,7 +40,7 @@ import Graphics.Color.Model.HSI import Graphics.Color.Model.HSL import Graphics.Color.Model.HSV -import Graphics.Color.Model.Internal +import Graphics.Color.Model.Internal hiding (MVector, Vector) import Graphics.Color.Model.RGB import Graphics.Color.Model.Y import Graphics.Color.Model.YCbCr diff --git a/src/Graphics/Color/Model/CMYK.hs b/src/Graphics/Color/Model/CMYK.hs --- a/src/Graphics/Color/Model/CMYK.hs +++ b/src/Graphics/Color/Model/CMYK.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Model.CMYK --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Model/HSI.hs b/src/Graphics/Color/Model/HSI.hs --- a/src/Graphics/Color/Model/HSI.hs +++ b/src/Graphics/Color/Model/HSI.hs @@ -11,7 +11,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Model.HSI --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Model/HSL.hs b/src/Graphics/Color/Model/HSL.hs --- a/src/Graphics/Color/Model/HSL.hs +++ b/src/Graphics/Color/Model/HSL.hs @@ -11,7 +11,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Model.HSL --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Model/HSV.hs b/src/Graphics/Color/Model/HSV.hs --- a/src/Graphics/Color/Model/HSV.hs +++ b/src/Graphics/Color/Model/HSV.hs @@ -11,7 +11,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Model.HSV --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Model/Internal.hs b/src/Graphics/Color/Model/Internal.hs --- a/src/Graphics/Color/Model/Internal.hs +++ b/src/Graphics/Color/Model/Internal.hs @@ -8,7 +8,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Graphics.Color.Model.Internal --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Model/RGB.hs b/src/Graphics/Color/Model/RGB.hs --- a/src/Graphics/Color/Model/RGB.hs +++ b/src/Graphics/Color/Model/RGB.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Model.RGB --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Model/Y.hs b/src/Graphics/Color/Model/Y.hs --- a/src/Graphics/Color/Model/Y.hs +++ b/src/Graphics/Color/Model/Y.hs @@ -9,7 +9,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Model.Y --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Model/YCbCr.hs b/src/Graphics/Color/Model/YCbCr.hs --- a/src/Graphics/Color/Model/YCbCr.hs +++ b/src/Graphics/Color/Model/YCbCr.hs @@ -13,7 +13,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Graphics.Color.Model.YCbCr --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Space.hs b/src/Graphics/Color/Space.hs --- a/src/Graphics/Color/Space.hs +++ b/src/Graphics/Color/Space.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Graphics.Color.Space --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Space/CIE1931/RGB.hs b/src/Graphics/Color/Space/CIE1931/RGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/CIE1931/RGB.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.CIE1931.RGB +-- Copyright : (c) Alexey Kuleshevich 2018-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.CIE1931.RGB + ( CIERGB + , primaries + , castLinearity + , module Graphics.Color.Space + ) where + +import Data.Coerce +import Data.Typeable +import Foreign.Storable +import Graphics.Color.Model.Internal +import qualified Graphics.Color.Model.RGB as CM +import Graphics.Color.Space +import Graphics.Color.Illuminant.CIE1931 + + +-- | The original @CIE1931 RGB@ color space with an arbitrary illuminant +data CIERGB (l :: Linearity) + +-- | `CIERGB` color space +newtype instance Color (CIERGB l) e = CIERGB (Color CM.RGB e) + +-- | `CIERGB` color space +deriving instance Eq e => Eq (Color (CIERGB l) e) +-- | `CIERGB` color space +deriving instance Ord e => Ord (Color (CIERGB l) e) +-- | `CIERGB` color space +deriving instance Functor (Color (CIERGB l)) +-- | `CIERGB` color space +deriving instance Applicative (Color (CIERGB l)) +-- | `CIERGB` color space +deriving instance Foldable (Color (CIERGB l)) +-- | `CIERGB` color space +deriving instance Traversable (Color (CIERGB l)) +-- | `CIERGB` color space +deriving instance Storable e => Storable (Color (CIERGB l) e) + +-- | `CIERGB` color space +instance (Typeable l, Elevator e) => Show (Color (CIERGB l) e) where + showsPrec _ = showsColorModel + +-- | `CIERGB` color space +instance (Typeable l, Elevator e) => ColorModel (CIERGB l) e where + type Components (CIERGB l) e = (e, e, e) + toComponents = toComponents . unColorRGB + {-# INLINE toComponents #-} + fromComponents = mkColorRGB . fromComponents + {-# INLINE fromComponents #-} + +-- | `CIERGB` linear color space +instance (Typeable l, Elevator e) => ColorSpace (CIERGB l) 'E e where + type BaseModel (CIERGB l) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . castLinearity . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat . castLinearity + {-# INLINE toColorXYZ #-} + fromColorXYZ xyz = castLinearity (fromRealFloat <$> (xyz2rgbLinear @CIERGB xyz)) + {-# INLINE fromColorXYZ #-} + +-- | `CIERGB` color space +instance RedGreenBlue CIERGB 'E where + gamut = primaries + ecctf = coerce + {-# INLINE ecctf #-} + dcctf = coerce + {-# INLINE dcctf #-} + +-- | CIE RGB does not utilize any gamma function, therefore it is safe to cast the +-- `Linearity` kind. +-- +-- @since 0.2.0 +castLinearity :: Color (CIERGB l') e -> Color (CIERGB l) e +castLinearity = coerce + + +-- | Primaries for CIERGB +-- +-- @since 0.2.0 +primaries :: RealFloat e => Gamut rgb i e +primaries = Gamut (Primary 0.734742840005998 0.265257159994002) + (Primary 0.273779033824958 0.717477700256116) + (Primary 0.166555629580280 0.008910726182545) +-- Source ^: https://github.com/colour-science/colour/blob/60679360c3990bc549b5f947bfeb621383e18b5e/colour/models/rgb/datasets/cie_rgb.py#L44-L48 diff --git a/src/Graphics/Color/Space/CIE1976/LAB.hs b/src/Graphics/Color/Space/CIE1976/LAB.hs --- a/src/Graphics/Color/Space/CIE1976/LAB.hs +++ b/src/Graphics/Color/Space/CIE1976/LAB.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Space.CIE1976.LAB --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Space/Internal.hs b/src/Graphics/Color/Space/Internal.hs --- a/src/Graphics/Color/Space/Internal.hs +++ b/src/Graphics/Color/Space/Internal.hs @@ -16,7 +16,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Space.Internal --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -106,7 +106,6 @@ instance ( ColorSpace cs i e , ColorSpace (BaseSpace cs) i e - , ColorSpace (Alpha (BaseSpace cs)) i e , cs ~ Opaque (Alpha cs) , BaseModel cs ~ Opaque (Alpha (BaseModel cs)) ) => @@ -130,7 +129,7 @@ -- | This is a data type that encodes a data point on the chromaticity diagram newtype Chromaticity i e = - Chromaticity (Color (CIExyY i) e) + Chromaticity { chromaticityCIExyY :: Color (CIExyY i) e } deriving (Eq, Show) @@ -152,7 +151,7 @@ newtype WhitePoint (i :: k) e = - WhitePointChromaticity (Chromaticity i e) + WhitePointChromaticity { whitePointChromaticity :: Chromaticity i e } deriving (Eq) instance (Illuminant i, Elevator e) => Show (WhitePoint (i :: k) e) where @@ -217,8 +216,11 @@ -- Primary -- ------------- -newtype Primary (i :: k) e = PrimaryChromaticity (Chromaticity i e) - deriving (Eq, Show) +newtype Primary (i :: k) e = + PrimaryChromaticity + { primaryChromaticity :: Chromaticity i e + } + deriving (Eq, Show) -- | Constructor for the most common @XYZ@ color space diff --git a/src/Graphics/Color/Space/RGB.hs b/src/Graphics/Color/Space/RGB.hs --- a/src/Graphics/Color/Space/RGB.hs +++ b/src/Graphics/Color/Space/RGB.hs @@ -7,7 +7,6 @@ -- Stability : experimental -- Portability : non-portable -- - module Graphics.Color.Space.RGB ( -- * Default sRGB color space pattern ColorSRGB diff --git a/src/Graphics/Color/Space/RGB/AdobeRGB.hs b/src/Graphics/Color/Space/RGB/AdobeRGB.hs --- a/src/Graphics/Color/Space/RGB/AdobeRGB.hs +++ b/src/Graphics/Color/Space/RGB/AdobeRGB.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Space.RGB.AdobeRGB --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -32,6 +32,8 @@ , module Graphics.Color.Space ) where +import Data.Typeable +import Data.Coerce import Foreign.Storable import Graphics.Color.Model.Internal import qualified Graphics.Color.Model.RGB as CM @@ -43,59 +45,73 @@ -- color space with the default `D65` illuminant -- -- @since 0.1.0 -data AdobeRGB +data AdobeRGB (l :: Linearity) -newtype instance Color AdobeRGB e = AdobeRGB (Color CM.RGB e) +newtype instance Color (AdobeRGB l) e = AdobeRGB (Color CM.RGB e) -- | Constructor for a color in @AdobeRGB@ color space -- -- @since 0.1.0 -pattern ColorAdobeRGB :: e -> e -> e -> Color AdobeRGB e +pattern ColorAdobeRGB :: e -> e -> e -> Color (AdobeRGB l) e pattern ColorAdobeRGB r g b = AdobeRGB (CM.ColorRGB r g b) {-# COMPLETE ColorAdobeRGB #-} -- | Constructor for a color in @AdobeRGB@ color space with alpha channel -- -- @since 0.1.0 -pattern ColorAdobeRGBA :: e -> e -> e -> e -> Color (Alpha AdobeRGB) e +pattern ColorAdobeRGBA :: e -> e -> e -> e -> Color (Alpha (AdobeRGB l)) e pattern ColorAdobeRGBA r g b a = Alpha (AdobeRGB (CM.ColorRGB r g b)) a {-# COMPLETE ColorAdobeRGBA #-} --- | Adobe`RGB` color space -deriving instance Eq e => Eq (Color AdobeRGB e) --- | Adobe`RGB` color space -deriving instance Ord e => Ord (Color AdobeRGB e) --- | Adobe`RGB` color space -deriving instance Functor (Color AdobeRGB) --- | Adobe`RGB` color space -deriving instance Applicative (Color AdobeRGB) --- | Adobe`RGB` color space -deriving instance Foldable (Color AdobeRGB) --- | Adobe`RGB` color space -deriving instance Traversable (Color AdobeRGB) --- | Adobe`RGB` color space -deriving instance Storable e => Storable (Color AdobeRGB e) +-- | `AdobeRGB` color space +deriving instance Eq e => Eq (Color (AdobeRGB l) e) +-- | `AdobeRGB` color space +deriving instance Ord e => Ord (Color (AdobeRGB l) e) +-- | `AdobeRGB` color space +deriving instance Functor (Color (AdobeRGB l)) +-- | `AdobeRGB` color space +deriving instance Applicative (Color (AdobeRGB l)) +-- | `AdobeRGB` color space +deriving instance Foldable (Color (AdobeRGB l)) +-- | `AdobeRGB` color space +deriving instance Traversable (Color (AdobeRGB l)) +-- | `AdobeRGB` color space +deriving instance Storable e => Storable (Color (AdobeRGB l) e) --- | Adobe`RGB` color space -instance Elevator e => Show (Color AdobeRGB e) where +-- | `AdobeRGB` color space +instance (Typeable l, Elevator e) => Show (Color (AdobeRGB l) e) where showsPrec _ = showsColorModel --- | Adobe`RGB` color space -instance Elevator e => ColorModel AdobeRGB e where - type Components AdobeRGB e = (e, e, e) +-- | `AdobeRGB` color space +instance (Typeable l, Elevator e) => ColorModel (AdobeRGB l) e where + type Components (AdobeRGB l) e = (e, e, e) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents {-# INLINE fromComponents #-} --- | Adobe`RGB` color space -instance Elevator e => ColorSpace AdobeRGB D65 e where - type BaseModel AdobeRGB = CM.RGB +-- | `AdobeRGB` linear color space +instance Elevator e => ColorSpace (AdobeRGB 'Linear) D65 e where + type BaseModel (AdobeRGB 'Linear) = CM.RGB toBaseSpace = id {-# INLINE toBaseSpace #-} fromBaseSpace = id {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear + {-# INLINE fromColorXYZ #-} + +-- | `AdobeRGB` color space +instance Elevator e => ColorSpace (AdobeRGB 'NonLinear) D65 e where + type BaseModel (AdobeRGB 'NonLinear) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} toColorXYZ = rgb2xyz . fmap toRealFloat @@ -103,25 +119,24 @@ fromColorXYZ = fmap fromRealFloat . xyz2rgb {-# INLINE fromColorXYZ #-} - --- | Adobe`RGB` color space +-- | `AdobeRGB` color space instance RedGreenBlue AdobeRGB D65 where gamut = primaries npm = npmStandard inpm = inpmStandard - ecctf = fmap transfer + ecctf = AdobeRGB . fmap transfer . coerce {-# INLINE ecctf #-} - dcctf = fmap itransfer + dcctf = AdobeRGB . fmap itransfer . coerce {-# INLINE dcctf #-} --- | sRGB normalized primary matrix. This is a helper definition, use `npm` instead. +-- | AdobeRGB normalized primary matrix. This is a helper definition, use `npm` instead. -- -- >>> :set -XDataKinds -- >>> import Graphics.Color.Space.RGB.AdobeRGB -- >>> npmStandard :: NPM AdobeRGB Float --- [ [ 0.576670, 0.185560, 0.188230 ] --- , [ 0.297340, 0.627360, 0.075290 ] --- , [ 0.027030, 0.070690, 0.991340 ] ] +-- [ [ 0.57667000, 0.18556000, 0.18823000 ] +-- , [ 0.29734000, 0.62736000, 0.07529000 ] +-- , [ 0.02703000, 0.07069000, 0.99134000 ] ] -- -- @since 0.1.0 npmStandard :: RealFloat e => NPM AdobeRGB e @@ -130,14 +145,14 @@ (V3 0.02703 0.07069 0.99134) --- | sRGB inverse normalized primary matrix. This is a helper definition, use `inpm` instead. +-- | AdobeRGB inverse normalized primary matrix. This is a helper definition, use `inpm` instead. -- -- >>> :set -XDataKinds -- >>> import Graphics.Color.Space.RGB.AdobeRGB -- >>> inpmStandard :: INPM AdobeRGB Float --- [ [ 2.041590,-0.565010,-0.344730 ] --- , [-0.969240, 1.875970, 0.041560 ] --- , [ 0.013440,-0.118360, 1.015170 ] ] +-- [ [ 2.04159000,-0.56501000,-0.34473000 ] +-- , [-0.96924000, 1.87597000, 0.04156000 ] +-- , [ 0.01344000,-0.11836000, 1.01517000 ] ] -- -- @since 0.1.0 inpmStandard :: RealFloat e => INPM AdobeRGB e @@ -170,7 +185,7 @@ itransfer u = u ** 2.19921875 -- in rational form 563/256 {-# INLINE itransfer #-} --- | @sRGB@ primaries +-- | @AdobeRGB@ primaries -- -- @since 0.1.0 primaries :: RealFloat e => Gamut rgb i e diff --git a/src/Graphics/Color/Space/RGB/Alternative.hs b/src/Graphics/Color/Space/RGB/Alternative.hs --- a/src/Graphics/Color/Space/RGB/Alternative.hs +++ b/src/Graphics/Color/Space/RGB/Alternative.hs @@ -1,7 +1,7 @@ {-# LANGUAGE PatternSynonyms #-} -- | -- Module : Graphics.Color.Space.RGB.Alternative --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental diff --git a/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs b/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs --- a/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs +++ b/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs @@ -12,7 +12,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Graphics.Color.Space.RGB.Alternative.CMYK --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -33,7 +33,13 @@ import qualified Graphics.Color.Model.CMYK as CM import Graphics.Color.Model.Internal import Graphics.Color.Space +import Graphics.Color.Space.RGB.AdobeRGB as AdobeRGB +import qualified Graphics.Color.Space.RGB.ITU.Rec470 as Rec470 +import Graphics.Color.Space.RGB.ITU.Rec601 +import Graphics.Color.Space.RGB.ITU.Rec709 +import Graphics.Color.Space.RGB.SRGB + -- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space data CMYK cs @@ -80,9 +86,89 @@ -- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space -instance (Typeable cs, ColorSpace cs i e, RedGreenBlue cs i) => ColorSpace (CMYK cs) i e where - type BaseModel (CMYK cs) = CM.CMYK - type BaseSpace (CMYK cs) = cs +instance (Typeable cs, ColorSpace (cs i l) i e, RedGreenBlue (cs i) i) => + ColorSpace (CMYK (cs i l)) i e where + type BaseModel (CMYK (cs i l)) = CM.CMYK + type BaseSpace (CMYK (cs i l)) = cs i l + toBaseSpace = mkColorRGB . fmap fromDouble . CM.cmyk2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2cmyk . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + + + +-- | `CMYK` representation for `SRGB` color space +instance ColorSpace (SRGB l) D65 e => ColorSpace (CMYK (SRGB l)) D65 e where + type BaseModel (CMYK (SRGB l)) = CM.CMYK + type BaseSpace (CMYK (SRGB l)) = SRGB l + toBaseSpace = mkColorRGB . fmap fromDouble . CM.cmyk2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2cmyk . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + +-- | `CMYK` representation for `AdobeRGB` color space +instance ColorSpace (AdobeRGB l) D65 e => ColorSpace (CMYK (AdobeRGB l)) D65 e where + type BaseModel (CMYK (AdobeRGB l)) = CM.CMYK + type BaseSpace (CMYK (AdobeRGB l)) = AdobeRGB l + toBaseSpace = mkColorRGB . fmap fromDouble . CM.cmyk2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2cmyk . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + +-- | `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 + type BaseModel (CMYK (Rec470.BT470_525 l)) = CM.CMYK + type BaseSpace (CMYK (Rec470.BT470_525 l)) = Rec470.BT470_525 l + toBaseSpace = mkColorRGB . fmap fromDouble . CM.cmyk2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2cmyk . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + +-- | `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 + type BaseModel (CMYK (Rec470.BT470_625 l)) = CM.CMYK + type BaseSpace (CMYK (Rec470.BT470_625 l)) = Rec470.BT470_625 l + toBaseSpace = mkColorRGB . fmap fromDouble . CM.cmyk2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2cmyk . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + +-- | `CMYK` representation for `BT601_525` color space +instance ColorSpace (BT601_525 l) D65 e => ColorSpace (CMYK (BT601_525 l)) D65 e where + type BaseModel (CMYK (BT601_525 l)) = CM.CMYK + type BaseSpace (CMYK (BT601_525 l)) = BT601_525 l + toBaseSpace = mkColorRGB . fmap fromDouble . CM.cmyk2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2cmyk . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + +-- | `CMYK` representation for `BT601_625` color space +instance ColorSpace (BT601_625 l) D65 e => ColorSpace (CMYK (BT601_625 l)) D65 e where + type BaseModel (CMYK (BT601_625 l)) = CM.CMYK + type BaseSpace (CMYK (BT601_625 l)) = BT601_625 l + toBaseSpace = mkColorRGB . fmap fromDouble . CM.cmyk2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2cmyk . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + +-- | `CMYK` representation for `BT709` color space +instance ColorSpace (BT709 l) D65 e => ColorSpace (CMYK (BT709 l)) D65 e where + type BaseModel (CMYK (BT709 l)) = CM.CMYK + type BaseSpace (CMYK (BT709 l)) = BT709 l toBaseSpace = mkColorRGB . fmap fromDouble . CM.cmyk2rgb . fmap toDouble . coerce {-# INLINE toBaseSpace #-} fromBaseSpace = coerce . fmap fromDouble . CM.rgb2cmyk . fmap toDouble . unColorRGB diff --git a/src/Graphics/Color/Space/RGB/Alternative/HSI.hs b/src/Graphics/Color/Space/RGB/Alternative/HSI.hs --- a/src/Graphics/Color/Space/RGB/Alternative/HSI.hs +++ b/src/Graphics/Color/Space/RGB/Alternative/HSI.hs @@ -13,7 +13,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Space.RGB.Alternative.HSI --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -30,7 +30,6 @@ import Data.Coerce import Data.Proxy -import Data.Typeable import Foreign.Storable import qualified Graphics.Color.Model.HSI as CM import Graphics.Color.Model.Internal @@ -92,9 +91,9 @@ -- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space -instance (Typeable cs, ColorSpace cs i e, RedGreenBlue cs i) => ColorSpace (HSI cs) i e where - type BaseModel (HSI cs) = CM.HSI - type BaseSpace (HSI cs) = cs +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 {-# INLINE toBaseSpace #-} fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsi . fmap toDouble . unColorRGB diff --git a/src/Graphics/Color/Space/RGB/Alternative/HSL.hs b/src/Graphics/Color/Space/RGB/Alternative/HSL.hs --- a/src/Graphics/Color/Space/RGB/Alternative/HSL.hs +++ b/src/Graphics/Color/Space/RGB/Alternative/HSL.hs @@ -13,7 +13,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Space.RGB.Alternative.HSL --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -30,7 +30,6 @@ import Data.Coerce import Data.Proxy -import Data.Typeable import Foreign.Storable import qualified Graphics.Color.Model.HSL as CM import Graphics.Color.Model.Internal @@ -91,9 +90,9 @@ -- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space -instance (Typeable cs, ColorSpace cs i e, RedGreenBlue cs i) => ColorSpace (HSL cs) i e where - type BaseModel (HSL cs) = CM.HSL - type BaseSpace (HSL cs) = cs +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 {-# INLINE toBaseSpace #-} fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsl . fmap toDouble . unColorRGB diff --git a/src/Graphics/Color/Space/RGB/Alternative/HSV.hs b/src/Graphics/Color/Space/RGB/Alternative/HSV.hs --- a/src/Graphics/Color/Space/RGB/Alternative/HSV.hs +++ b/src/Graphics/Color/Space/RGB/Alternative/HSV.hs @@ -13,7 +13,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Space.RGB.Alternative.HSV --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -90,9 +90,9 @@ -- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space -instance (ColorSpace cs i e, RedGreenBlue cs i) => ColorSpace (HSV cs) i e where - type BaseModel (HSV cs) = CM.HSV - type BaseSpace (HSV cs) = cs +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 {-# INLINE toBaseSpace #-} fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsv . fmap toDouble . unColorRGB diff --git a/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs b/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs --- a/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs +++ b/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs @@ -13,7 +13,7 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Graphics.Color.Space.RGB.Alternative.YCbCr --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -88,9 +88,9 @@ showsColorModelName _ = ("YCbCr-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) -- | `YCbCr` representation for `SRGB` color space -instance Elevator e => ColorSpace (YCbCr SRGB) D65 e where - type BaseModel (YCbCr SRGB) = CM.YCbCr - type BaseSpace (YCbCr SRGB) = SRGB +instance Elevator e => ColorSpace (YCbCr (SRGB 'NonLinear)) D65 e where + type BaseModel (YCbCr (SRGB 'NonLinear)) = CM.YCbCr + type BaseSpace (YCbCr (SRGB 'NonLinear)) = SRGB 'NonLinear toBaseSpace = fmap fromRealFloat . ycbcr2srgb . fmap toFloat {-# INLINE toBaseSpace #-} fromBaseSpace = fmap fromRealFloat . srgb2ycbcr . fmap toFloat @@ -99,9 +99,9 @@ {-# INLINE luminance #-} -- | `YCbCr` representation for `BT601_525` color space -instance Elevator e => ColorSpace (YCbCr BT601_525) D65 e where - type BaseModel (YCbCr BT601_525) = CM.YCbCr - type BaseSpace (YCbCr BT601_525) = BT601_525 +instance Elevator e => ColorSpace (YCbCr (BT601_525 'NonLinear)) D65 e where + type BaseModel (YCbCr (BT601_525 'NonLinear)) = CM.YCbCr + type BaseSpace (YCbCr (BT601_525 'NonLinear)) = BT601_525 'NonLinear toBaseSpace = fmap fromDouble . fromColorYCbCr {-# INLINE toBaseSpace #-} fromBaseSpace = fmap fromDouble . toColorYCbCr @@ -110,9 +110,9 @@ {-# INLINE luminance #-} -- | `YCbCr` representation for `BT601_625` color space -instance Elevator e => ColorSpace (YCbCr BT601_625) D65 e where - type BaseModel (YCbCr BT601_625) = CM.YCbCr - type BaseSpace (YCbCr BT601_625) = BT601_625 +instance Elevator e => ColorSpace (YCbCr (BT601_625 'NonLinear)) D65 e where + type BaseModel (YCbCr (BT601_625 'NonLinear)) = CM.YCbCr + type BaseSpace (YCbCr (BT601_625 'NonLinear)) = BT601_625 'NonLinear toBaseSpace = fmap fromDouble . fromColorYCbCr {-# INLINE toBaseSpace #-} fromBaseSpace = fmap fromDouble . toColorYCbCr @@ -121,9 +121,9 @@ {-# INLINE luminance #-} -- | `YCbCr` representation for `BT709` color space -instance Elevator e => ColorSpace (YCbCr BT709) D65 e where - type BaseModel (YCbCr BT709) = CM.YCbCr - type BaseSpace (YCbCr BT709) = BT709 +instance Elevator e => ColorSpace (YCbCr (BT709 'NonLinear)) D65 e where + type BaseModel (YCbCr (BT709 'NonLinear)) = CM.YCbCr + type BaseSpace (YCbCr (BT709 'NonLinear)) = BT709 'NonLinear toBaseSpace = fmap fromDouble . fromColorYCbCr {-# INLINE toBaseSpace #-} fromBaseSpace = fmap fromDouble . toColorYCbCr @@ -132,10 +132,10 @@ {-# INLINE luminance #-} -- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space -instance (Luma (cs i), ColorSpace (cs i) i e, RedGreenBlue (cs i) i) => - ColorSpace (YCbCr (cs i)) i e where - type BaseModel (YCbCr (cs i)) = CM.YCbCr - type BaseSpace (YCbCr (cs i)) = cs i +instance (Luma (cs i), ColorSpace (cs i 'NonLinear) i e, RedGreenBlue (cs i) i) => + ColorSpace (YCbCr (cs i 'NonLinear)) i e where + type BaseModel (YCbCr (cs i 'NonLinear)) = CM.YCbCr + type BaseSpace (YCbCr (cs i 'NonLinear)) = cs i 'NonLinear toBaseSpace = fmap fromDouble . fromColorYCbCr {-# INLINE toBaseSpace #-} fromBaseSpace = fmap fromDouble . toColorYCbCr @@ -147,7 +147,8 @@ -- | This conversion is only correct for sRGB and Rec601. Source: ITU-T Rec. T.871 -- -- @since 0.1.3 -ycbcr2srgb :: (RedGreenBlue cs i, RealFloat e) => Color (YCbCr cs) e -> Color cs e +ycbcr2srgb :: + (RedGreenBlue cs i, RealFloat e) => Color (YCbCr (cs 'NonLinear)) e -> Color (cs 'NonLinear) e ycbcr2srgb (ColorYCbCr y' cb cr) = ColorRGB r' g' b' where !cb05 = cb - 0.5 @@ -160,7 +161,8 @@ -- | This conversion is only correct for sRGB and Rec601. Source: ITU-T Rec. T.871 -- -- @since 0.1.3 -srgb2ycbcr :: (RedGreenBlue cs i, RealFloat e) => Color cs e -> Color (YCbCr cs) e +srgb2ycbcr :: + (RedGreenBlue cs i, RealFloat e) => Color (cs 'NonLinear) e -> Color (YCbCr (cs 'NonLinear)) e srgb2ycbcr (ColorRGB r' g' b') = ColorYCbCr y' cb cr where !y' = 0.299 * r' + 0.587 * g' + 0.114 * b' @@ -173,8 +175,8 @@ -- @since 0.1.3 toColorYCbCr :: forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e) - => Color cs e' - -> Color (YCbCr cs) e + => Color (cs 'NonLinear) e' + -> Color (YCbCr (cs 'NonLinear)) e toColorYCbCr rgb = YCbCr (CM.rgb2ycbcr (unColorRGB rgb) weights) where !weights = rgbLumaWeights rgb @@ -185,8 +187,8 @@ -- @since 0.1.3 fromColorYCbCr :: forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e) - => Color (YCbCr cs) e' - -> Color cs e + => Color (YCbCr (cs 'NonLinear)) e' + -> Color (cs 'NonLinear) e fromColorYCbCr ycbcr = rgb where !rgb = mkColorRGB (CM.ycbcr2rgb (coerce ycbcr :: Color CM.YCbCr e') weights) diff --git a/src/Graphics/Color/Space/RGB/CIERGB.hs b/src/Graphics/Color/Space/RGB/CIERGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/CIERGB.hs @@ -0,0 +1,13 @@ +-- | +-- Module : Graphics.Color.Space.RGB.Derived.CIERGB +-- Copyright : (c) Alexey Kuleshevich 2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.CIERGB + ( module Graphics.Color.Space.CIE1931.RGB + ) where + +import Graphics.Color.Space.CIE1931.RGB diff --git a/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs b/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs --- a/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs +++ b/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Space.RGB.Derived.AdobeRGB --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -25,6 +25,8 @@ , module Graphics.Color.Space ) where +import Data.Coerce +import Data.Typeable import Foreign.Storable import Graphics.Color.Model.Internal import qualified Graphics.Color.Model.RGB as CM @@ -33,41 +35,55 @@ -- | The most common @AdobeRGB@ color space with an arbitrary illuminant -data AdobeRGB (i :: k) +data AdobeRGB (i :: k) (l :: Linearity) -- | `AdobeRGB` color space (derived) -newtype instance Color (AdobeRGB i) e = AdobeRGB (Color CM.RGB e) +newtype instance Color (AdobeRGB i l) e = AdobeRGB (Color CM.RGB e) -- | `AdobeRGB` color space (derived) -deriving instance Eq e => Eq (Color (AdobeRGB i) e) +deriving instance Eq e => Eq (Color (AdobeRGB i l) e) -- | `AdobeRGB` color space (derived) -deriving instance Ord e => Ord (Color (AdobeRGB i) e) +deriving instance Ord e => Ord (Color (AdobeRGB i l) e) -- | `AdobeRGB` color space (derived) -deriving instance Functor (Color (AdobeRGB i)) +deriving instance Functor (Color (AdobeRGB i l)) -- | `AdobeRGB` color space (derived) -deriving instance Applicative (Color (AdobeRGB i)) +deriving instance Applicative (Color (AdobeRGB i l)) -- | `AdobeRGB` color space (derived) -deriving instance Foldable (Color (AdobeRGB i)) +deriving instance Foldable (Color (AdobeRGB i l)) -- | `AdobeRGB` color space (derived) -deriving instance Traversable (Color (AdobeRGB i)) +deriving instance Traversable (Color (AdobeRGB i l)) -- | `AdobeRGB` color space (derived) -deriving instance Storable e => Storable (Color (AdobeRGB i) e) +deriving instance Storable e => Storable (Color (AdobeRGB i l) e) -- | `AdobeRGB` color space (derived) -instance (Illuminant i, Elevator e) => Show (Color (AdobeRGB (i :: k)) e) where +instance (Typeable l, Illuminant i, Elevator e) => Show (Color (AdobeRGB (i :: k) l) e) where showsPrec _ = showsColorModel -- | `AdobeRGB` color space (derived) -instance (Illuminant i, Elevator e) => ColorModel (AdobeRGB (i :: k)) e where - type Components (AdobeRGB i) e = (e, e, e) +instance (Typeable l, Illuminant i, Elevator e) => ColorModel (AdobeRGB (i :: k) l) e where + type Components (AdobeRGB i l) e = (e, e, e) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents {-# INLINE fromComponents #-} +-- | `AdobeRGB` linear color space (derived) +instance (Illuminant i, Elevator e) => ColorSpace (AdobeRGB i 'Linear) i e where + type BaseModel (AdobeRGB i 'Linear) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear + {-# INLINE fromColorXYZ #-} + -- | `AdobeRGB` color space (derived) -instance (Illuminant i, Elevator e) => ColorSpace (AdobeRGB i) i e where - type BaseModel (AdobeRGB i) = CM.RGB +instance (Illuminant i, Elevator e) => ColorSpace (AdobeRGB i 'NonLinear) i e where + type BaseModel (AdobeRGB i 'NonLinear) = CM.RGB toBaseSpace = id {-# INLINE toBaseSpace #-} fromBaseSpace = id @@ -82,7 +98,7 @@ -- | `AdobeRGB` color space (derived) instance Illuminant i => RedGreenBlue (AdobeRGB i) i where gamut = AdobeRGB.primaries - ecctf = fmap AdobeRGB.transfer + ecctf = AdobeRGB . fmap AdobeRGB.transfer . coerce {-# INLINE ecctf #-} - dcctf = fmap AdobeRGB.itransfer + dcctf = AdobeRGB . fmap AdobeRGB.itransfer . coerce {-# INLINE dcctf #-} diff --git a/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs b/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Derived/CIERGB.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.RGB.Derived.CIERGB +-- Copyright : (c) Alexey Kuleshevich 2018-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Derived.CIERGB + ( CIERGB + , CIERGB.primaries + , castLinearity + , module Graphics.Color.Space + ) where + +import Data.Coerce +import Data.Typeable +import Foreign.Storable +import Graphics.Color.Model.Internal +import qualified Graphics.Color.Model.RGB as CM +import Graphics.Color.Space +import qualified Graphics.Color.Space.CIE1931.RGB as CIERGB + + +-- | The original @CIE1931 RGB@ color space with an arbitrary illuminant +data CIERGB (i :: k) (l :: Linearity) + +-- | `CIERGB` color space (derived) +newtype instance Color (CIERGB i l) e = CIERGB (Color CM.RGB e) + +-- | `CIERGB` color space (derived) +deriving instance Eq e => Eq (Color (CIERGB i l) e) +-- | `CIERGB` color space (derived) +deriving instance Ord e => Ord (Color (CIERGB i l) e) +-- | `CIERGB` color space (derived) +deriving instance Functor (Color (CIERGB i l)) +-- | `CIERGB` color space (derived) +deriving instance Applicative (Color (CIERGB i l)) +-- | `CIERGB` color space (derived) +deriving instance Foldable (Color (CIERGB i l)) +-- | `CIERGB` color space (derived) +deriving instance Traversable (Color (CIERGB i l)) +-- | `CIERGB` color space (derived) +deriving instance Storable e => Storable (Color (CIERGB i l) e) + +-- | `CIERGB` color space (derived) +instance (Typeable l, Illuminant i, Elevator e) => Show (Color (CIERGB (i :: k) l) e) where + showsPrec _ = showsColorModel + +-- | `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) + toComponents = toComponents . unColorRGB + {-# INLINE toComponents #-} + fromComponents = mkColorRGB . fromComponents + {-# INLINE fromComponents #-} + +-- | `CIERGB` linear color space (derived) +instance (Illuminant i, Typeable l, Elevator e) => ColorSpace (CIERGB i l) i e where + type BaseModel (CIERGB i l) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . castLinearity . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat . castLinearity + {-# INLINE toColorXYZ #-} + fromColorXYZ xyz = castLinearity (fromRealFloat <$> (xyz2rgbLinear @(CIERGB i) xyz)) + {-# INLINE fromColorXYZ #-} + +-- | `CIERGB` color space (derived) +instance Illuminant i => RedGreenBlue (CIERGB i) i where + gamut = CIERGB.primaries + ecctf = coerce + {-# INLINE ecctf #-} + dcctf = coerce + {-# INLINE dcctf #-} + +-- | CIE RGB does not utilize any gamma function, therefore it is safe to cast the +-- `Linearity` kind. +-- +-- @since 0.2.0 +castLinearity :: Color (CIERGB i l') e -> Color (CIERGB i l) e +castLinearity = coerce diff --git a/src/Graphics/Color/Space/RGB/Derived/SRGB.hs b/src/Graphics/Color/Space/RGB/Derived/SRGB.hs --- a/src/Graphics/Color/Space/RGB/Derived/SRGB.hs +++ b/src/Graphics/Color/Space/RGB/Derived/SRGB.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Space.RGB.Derived.SRGB --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -25,6 +25,8 @@ , module Graphics.Color.Space ) where +import Data.Coerce +import Data.Typeable import Foreign.Storable import Graphics.Color.Model.Internal import qualified Graphics.Color.Model.RGB as CM @@ -34,41 +36,56 @@ -- | The most common @sRGB@ color space with an arbitrary illuminant -data SRGB (i :: k) +data SRGB (i :: k) (l :: Linearity) -- | `SRGB` color space (derived) -newtype instance Color (SRGB i) e = SRGB (Color CM.RGB e) +newtype instance Color (SRGB i l) e = SRGB (Color CM.RGB e) -- | `SRGB` color space (derived) -deriving instance Eq e => Eq (Color (SRGB i) e) +deriving instance Eq e => Eq (Color (SRGB i l) e) -- | `SRGB` color space (derived) -deriving instance Ord e => Ord (Color (SRGB i) e) +deriving instance Ord e => Ord (Color (SRGB i l) e) -- | `SRGB` color space (derived) -deriving instance Functor (Color (SRGB i)) +deriving instance Functor (Color (SRGB i l)) -- | `SRGB` color space (derived) -deriving instance Applicative (Color (SRGB i)) +deriving instance Applicative (Color (SRGB i l)) -- | `SRGB` color space (derived) -deriving instance Foldable (Color (SRGB i)) +deriving instance Foldable (Color (SRGB i l)) -- | `SRGB` color space (derived) -deriving instance Traversable (Color (SRGB i)) +deriving instance Traversable (Color (SRGB i l)) -- | `SRGB` color space (derived) -deriving instance Storable e => Storable (Color (SRGB i) e) +deriving instance Storable e => Storable (Color (SRGB i l) e) -- | `SRGB` color space (derived) -instance (Illuminant i, Elevator e) => Show (Color (SRGB (i :: k)) e) where +instance (Typeable l, Illuminant i, Elevator e) => Show (Color (SRGB (i :: k) l) e) where showsPrec _ = showsColorModel -- | `SRGB` color space (derived) -instance (Illuminant i, Elevator e) => ColorModel (SRGB (i :: k)) e where - type Components (SRGB i) e = (e, e, e) +instance (Typeable l, Illuminant i, Elevator e) => ColorModel (SRGB (i :: k) l) e where + type Components (SRGB i l) e = (e, e, e) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents {-# INLINE fromComponents #-} +-- | `SRGB` linear color space (derived) +instance (Illuminant i, Elevator e) => ColorSpace (SRGB i 'Linear) i e where + type BaseModel (SRGB i 'Linear) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear + {-# INLINE fromColorXYZ #-} + + -- | `SRGB` color space (derived) -instance (Illuminant i, Elevator e) => ColorSpace (SRGB i) i e where - type BaseModel (SRGB i) = CM.RGB +instance (Illuminant i, Elevator e) => ColorSpace (SRGB i 'NonLinear) i e where + type BaseModel (SRGB i 'NonLinear) = CM.RGB toBaseSpace = id {-# INLINE toBaseSpace #-} fromBaseSpace = id @@ -83,9 +100,9 @@ -- | `SRGB` color space (derived) instance Illuminant i => RedGreenBlue (SRGB i) i where gamut = SRGB.primaries - ecctf = fmap SRGB.transfer + ecctf = SRGB . fmap SRGB.transfer . coerce {-# INLINE ecctf #-} - dcctf = fmap SRGB.itransfer + dcctf = SRGB . fmap SRGB.itransfer . coerce {-# INLINE dcctf #-} diff --git a/src/Graphics/Color/Space/RGB/ITU/Rec470.hs b/src/Graphics/Color/Space/RGB/ITU/Rec470.hs --- a/src/Graphics/Color/Space/RGB/ITU/Rec470.hs +++ b/src/Graphics/Color/Space/RGB/ITU/Rec470.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Space.RGB.ITU.Rec470 --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -29,6 +29,8 @@ , module Graphics.Color.Space ) where +import Data.Coerce +import Data.Typeable import Foreign.Storable import qualified Graphics.Color.Model.RGB as CM import Graphics.Color.Space @@ -39,44 +41,58 @@ ------------------------------------ -- | [ITU-R BT.470](https://www.itu.int/rec/R-REC-BT.470) (525) color space. Used in NTSC -data BT470_525 +data BT470_525 (l :: Linearity) -newtype instance Color BT470_525 e = BT470_525 (Color CM.RGB e) +newtype instance Color (BT470_525 l) e = BT470_525 (Color CM.RGB e) -- | ITU-R BT.470 (525) color space -deriving instance Eq e => Eq (Color BT470_525 e) +deriving instance Eq e => Eq (Color (BT470_525 l) e) -- | ITU-R BT.470 (525) color space -deriving instance Ord e => Ord (Color BT470_525 e) +deriving instance Ord e => Ord (Color (BT470_525 l) e) -- | ITU-R BT.470 (525) color space -deriving instance Functor (Color BT470_525) +deriving instance Functor (Color (BT470_525 l)) -- | ITU-R BT.470 (525) color space -deriving instance Applicative (Color BT470_525) +deriving instance Applicative (Color (BT470_525 l)) -- | ITU-R BT.470 (525) color space -deriving instance Foldable (Color BT470_525) +deriving instance Foldable (Color (BT470_525 l)) -- | ITU-R BT.470 (525) color space -deriving instance Traversable (Color BT470_525) +deriving instance Traversable (Color (BT470_525 l)) -- | ITU-R BT.470 (525) color space -deriving instance Storable e => Storable (Color BT470_525 e) +deriving instance Storable e => Storable (Color (BT470_525 l) e) -- | ITU-R BT.470 (525) color space -instance Elevator e => Show (Color BT470_525 e) where +instance (Typeable l, Elevator e) => Show (Color (BT470_525 l) e) where showsPrec _ = showsColorModel -- | ITU-R BT.470 (525) color space -instance Elevator e => ColorModel BT470_525 e where - type Components BT470_525 e = (e, e, e) +instance (Typeable l, Elevator e) => ColorModel (BT470_525 l) e where + type Components (BT470_525 l) e = (e, e, e) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents {-# INLINE fromComponents #-} -- | ITU-R BT.470 (525) color space -instance Elevator e => ColorSpace BT470_525 C e where - type BaseModel BT470_525 = CM.RGB +instance Elevator e => ColorSpace (BT470_525 'Linear) C e where + type BaseModel (BT470_525 'Linear) = CM.RGB toBaseSpace = id {-# INLINE toBaseSpace #-} fromBaseSpace = id {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear + {-# INLINE fromColorXYZ #-} + +-- | ITU-R BT.470 (525) color space +instance Elevator e => ColorSpace (BT470_525 'NonLinear) C e where + type BaseModel (BT470_525 'NonLinear) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} toColorXYZ = rgb2xyz . fmap toRealFloat @@ -87,9 +103,9 @@ -- | ITU-R BT.470 (525) color space instance RedGreenBlue BT470_525 C where gamut = primaries525 - ecctf = fmap (gamma 2.2) + ecctf c = BT470_525 (fmap (gamma 2.2) (coerce c)) {-# INLINE ecctf #-} - dcctf = fmap (igamma 2.2) + dcctf c = BT470_525 (fmap (igamma 2.2) (coerce c)) {-# INLINE dcctf #-} ------------------------------------ @@ -97,44 +113,58 @@ ------------------------------------ -- | [ITU-R BT.470](https://www.itu.int/rec/R-REC-BT.470) (625) color space. Used in PAL/SECAM -data BT470_625 +data BT470_625 (l :: Linearity) -newtype instance Color BT470_625 e = BT470_625 (Color CM.RGB e) +newtype instance Color (BT470_625 l) e = BT470_625 (Color CM.RGB e) -- | ITU-R BT.470 (625) color space -deriving instance Eq e => Eq (Color BT470_625 e) +deriving instance Eq e => Eq (Color (BT470_625 l) e) -- | ITU-R BT.470 (625) color space -deriving instance Ord e => Ord (Color BT470_625 e) +deriving instance Ord e => Ord (Color (BT470_625 l) e) -- | ITU-R BT.470 (625) color space -deriving instance Functor (Color BT470_625) +deriving instance Functor (Color (BT470_625 l)) -- | ITU-R BT.470 (625) color space -deriving instance Applicative (Color BT470_625) +deriving instance Applicative (Color (BT470_625 l)) -- | ITU-R BT.470 (625) color space -deriving instance Foldable (Color BT470_625) +deriving instance Foldable (Color (BT470_625 l)) -- | ITU-R BT.470 (625) color space -deriving instance Traversable (Color BT470_625) +deriving instance Traversable (Color (BT470_625 l)) -- | ITU-R BT.470 (625) color space -deriving instance Storable e => Storable (Color BT470_625 e) +deriving instance Storable e => Storable (Color (BT470_625 l) e) -- | ITU-R BT.470 (625) color space -instance Elevator e => Show (Color BT470_625 e) where +instance (Typeable l, Elevator e) => Show (Color (BT470_625 l) e) where showsPrec _ = showsColorModel -- | ITU-R BT.470 (625) color space -instance Elevator e => ColorModel BT470_625 e where - type Components BT470_625 e = (e, e, e) +instance (Typeable l, Elevator e) => ColorModel (BT470_625 l) e where + type Components (BT470_625 l) e = (e, e, e) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents {-# INLINE fromComponents #-} -- | ITU-R BT.470 (625) color space -instance Elevator e => ColorSpace BT470_625 D65 e where - type BaseModel BT470_625 = CM.RGB +instance Elevator e => ColorSpace (BT470_625 'Linear) D65 e where + type BaseModel (BT470_625 'Linear) = CM.RGB toBaseSpace = id {-# INLINE toBaseSpace #-} fromBaseSpace = id {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear + {-# INLINE fromColorXYZ #-} + +-- | ITU-R BT.470 (625) color space +instance Elevator e => ColorSpace (BT470_625 'NonLinear) D65 e where + type BaseModel (BT470_625 'NonLinear) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} toColorXYZ = rgb2xyz . fmap toRealFloat @@ -145,9 +175,9 @@ -- | ITU-R BT.470 (625) color space instance RedGreenBlue BT470_625 D65 where gamut = primaries625 - ecctf = fmap (gamma 2.8) + ecctf c = BT470_625 (fmap (gamma 2.8) (coerce c)) {-# INLINE ecctf #-} - dcctf = fmap (igamma 2.8) + dcctf c = BT470_625 (fmap (igamma 2.8) (coerce c)) {-# INLINE dcctf #-} gamma :: Floating a => a -> a -> a diff --git a/src/Graphics/Color/Space/RGB/ITU/Rec601.hs b/src/Graphics/Color/Space/RGB/ITU/Rec601.hs --- a/src/Graphics/Color/Space/RGB/ITU/Rec601.hs +++ b/src/Graphics/Color/Space/RGB/ITU/Rec601.hs @@ -12,7 +12,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Space.RGB.ITU.Rec601 --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -31,13 +31,15 @@ , module Graphics.Color.Space ) 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 Graphics.Color.Space import Graphics.Color.Space.RGB.ITU.Rec470 (primaries625) import Graphics.Color.Space.RGB.Luma -import Graphics.Color.Illuminant.ITU.Rec601 @@ -46,44 +48,59 @@ ------------------------------------ -- | [ITU-R BT.601](https://en.wikipedia.org/wiki/Rec._601) (525) color space -data BT601_525 +data BT601_525 (l :: Linearity) -newtype instance Color BT601_525 e = BT601_525 (Color CM.RGB e) +newtype instance Color (BT601_525 l) e = BT601_525 (Color CM.RGB e) -- | ITU-R BT.601 (525) color space -deriving instance Eq e => Eq (Color BT601_525 e) +deriving instance Eq e => Eq (Color (BT601_525 l) e) -- | ITU-R BT.601 (525) color space -deriving instance Ord e => Ord (Color BT601_525 e) +deriving instance Ord e => Ord (Color (BT601_525 l) e) -- | ITU-R BT.601 (525) color space -deriving instance Functor (Color BT601_525) +deriving instance Functor (Color (BT601_525 l)) -- | ITU-R BT.601 (525) color space -deriving instance Applicative (Color BT601_525) +deriving instance Applicative (Color (BT601_525 l)) -- | ITU-R BT.601 (525) color space -deriving instance Foldable (Color BT601_525) +deriving instance Foldable (Color (BT601_525 l)) -- | ITU-R BT.601 (525) color space -deriving instance Traversable (Color BT601_525) +deriving instance Traversable (Color (BT601_525 l)) -- | ITU-R BT.601 (525) color space -deriving instance Storable e => Storable (Color BT601_525 e) +deriving instance Storable e => Storable (Color (BT601_525 l) e) -- | ITU-R BT.601 (525) color space -instance Elevator e => Show (Color BT601_525 e) where +instance (Typeable l, Elevator e) => Show (Color (BT601_525 l) e) where showsPrec _ = showsColorModel -- | ITU-R BT.601 (525) color space -instance Elevator e => ColorModel BT601_525 e where - type Components BT601_525 e = (e, e, e) +instance (Typeable l, Elevator e) => ColorModel (BT601_525 l) e where + type Components (BT601_525 l) e = (e, e, e) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents {-# INLINE fromComponents #-} --- | ITU-R BT.601 (525) color space -instance Elevator e => ColorSpace BT601_525 D65 e where - type BaseModel BT601_525 = CM.RGB +-- | ITU-R BT.601 (525) linear color space +instance Elevator e => ColorSpace (BT601_525 'Linear) D65 e where + type BaseModel (BT601_525 'Linear) = CM.RGB toBaseSpace = id {-# INLINE toBaseSpace #-} fromBaseSpace = id {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear + {-# INLINE fromColorXYZ #-} + + +-- | ITU-R BT.601 (525) linear color space +instance Elevator e => ColorSpace (BT601_525 'NonLinear) D65 e where + type BaseModel (BT601_525 'NonLinear) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} toColorXYZ = rgb2xyz . fmap toRealFloat @@ -94,9 +111,9 @@ -- | ITU-R BT.601 (525) color space instance RedGreenBlue BT601_525 D65 where gamut = primaries525 - ecctf = fmap transfer + ecctf = BT601_525 . fmap transfer . coerce {-# INLINE ecctf #-} - dcctf = fmap itransfer + dcctf = BT601_525 . fmap itransfer . coerce {-# INLINE dcctf #-} ------------------------------------ @@ -104,40 +121,54 @@ ------------------------------------ -- | [ITU-R BT.601](https://en.wikipedia.org/wiki/Rec._601) (625) color space -data BT601_625 +data BT601_625 (l :: Linearity) -newtype instance Color BT601_625 e = BT601_625 (Color CM.RGB e) +newtype instance Color (BT601_625 l) e = BT601_625 (Color CM.RGB e) -- | ITU-R BT.601 (625) color space -deriving instance Eq e => Eq (Color BT601_625 e) +deriving instance Eq e => Eq (Color (BT601_625 l) e) -- | ITU-R BT.601 (625) color space -deriving instance Ord e => Ord (Color BT601_625 e) +deriving instance Ord e => Ord (Color (BT601_625 l) e) -- | ITU-R BT.601 (625) color space -deriving instance Functor (Color BT601_625) +deriving instance Functor (Color (BT601_625 l)) -- | ITU-R BT.601 (625) color space -deriving instance Applicative (Color BT601_625) +deriving instance Applicative (Color (BT601_625 l)) -- | ITU-R BT.601 (625) color space -deriving instance Foldable (Color BT601_625) +deriving instance Foldable (Color (BT601_625 l)) -- | ITU-R BT.601 (625) color space -deriving instance Traversable (Color BT601_625) +deriving instance Traversable (Color (BT601_625 l)) -- | ITU-R BT.601 (625) color space -deriving instance Storable e => Storable (Color BT601_625 e) +deriving instance Storable e => Storable (Color (BT601_625 l) e) -- | ITU-R BT.601 (625) color space -instance Elevator e => Show (Color BT601_625 e) where +instance (Typeable l, Elevator e) => Show (Color (BT601_625 l) e) where showsPrec _ = showsColorModel -- | ITU-R BT.601 (625) color space -instance Elevator e => ColorModel BT601_625 e where - type Components BT601_625 e = (e, e, e) +instance (Typeable l, Elevator e) => ColorModel (BT601_625 l) e where + type Components (BT601_625 l) e = (e, e, e) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents {-# INLINE fromComponents #-} +-- | ITU-R BT.601 (625) linear color space +instance Elevator e => ColorSpace (BT601_625 'Linear) D65 e where + type BaseModel (BT601_625 'Linear) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear + {-# INLINE fromColorXYZ #-} + -- | ITU-R BT.601 (625) color space -instance Elevator e => ColorSpace BT601_625 D65 e where - type BaseModel BT601_625 = CM.RGB +instance Elevator e => ColorSpace (BT601_625 'NonLinear) D65 e where + type BaseModel (BT601_625 'NonLinear) = CM.RGB toBaseSpace = id {-# INLINE toBaseSpace #-} fromBaseSpace = id @@ -152,9 +183,9 @@ -- | ITU-R BT.601 (625) color space instance RedGreenBlue BT601_625 D65 where gamut = primaries625 - ecctf = fmap transfer + ecctf = BT601_625 . fmap transfer . coerce {-# INLINE ecctf #-} - dcctf = fmap itransfer + dcctf = BT601_625 . fmap itransfer . coerce {-# INLINE dcctf #-} instance Luma BT601_525 where diff --git a/src/Graphics/Color/Space/RGB/ITU/Rec709.hs b/src/Graphics/Color/Space/RGB/ITU/Rec709.hs --- a/src/Graphics/Color/Space/RGB/ITU/Rec709.hs +++ b/src/Graphics/Color/Space/RGB/ITU/Rec709.hs @@ -11,7 +11,7 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Space.RGB.ITU.Rec709 --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -27,6 +27,8 @@ , module Graphics.Color.Space ) where +import Data.Coerce +import Data.Typeable import Foreign.Storable import Graphics.Color.Model.Internal import qualified Graphics.Color.Model.RGB as CM @@ -35,40 +37,54 @@ import Graphics.Color.Space.RGB.Luma -- | [ITU-R BT.709](https://en.wikipedia.org/wiki/Rec._709) color space -data BT709 +data BT709 (l :: Linearity) -newtype instance Color BT709 e = BT709 (Color CM.RGB e) +newtype instance Color (BT709 l) e = BT709 (Color CM.RGB e) -- | ITU-R BT.709 color space -deriving instance Eq e => Eq (Color BT709 e) +deriving instance Eq e => Eq (Color (BT709 l) e) -- | ITU-R BT.709 color space -deriving instance Ord e => Ord (Color BT709 e) +deriving instance Ord e => Ord (Color (BT709 l) e) -- | ITU-R BT.709 color space -deriving instance Functor (Color BT709) +deriving instance Functor (Color (BT709 l)) -- | ITU-R BT.709 color space -deriving instance Applicative (Color BT709) +deriving instance Applicative (Color (BT709 l)) -- | ITU-R BT.709 color space -deriving instance Foldable (Color BT709) +deriving instance Foldable (Color (BT709 l)) -- | ITU-R BT.709 color space -deriving instance Traversable (Color BT709) +deriving instance Traversable (Color (BT709 l)) -- | ITU-R BT.709 color space -deriving instance Storable e => Storable (Color BT709 e) +deriving instance Storable e => Storable (Color (BT709 l) e) -- | ITU-R BT.709 color space -instance Elevator e => Show (Color BT709 e) where +instance (Typeable l, Elevator e) => Show (Color (BT709 l) e) where showsPrec _ = showsColorModel -- | ITU-R BT.709 color space -instance Elevator e => ColorModel BT709 e where - type Components BT709 e = (e, e, e) +instance (Typeable l, Elevator e) => ColorModel (BT709 l) e where + type Components (BT709 l) e = (e, e, e) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents {-# INLINE fromComponents #-} +-- | ITU-R BT.709 linear color space +instance Elevator e => ColorSpace (BT709 'Linear) D65 e where + type BaseModel (BT709 'Linear) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear + {-# INLINE fromColorXYZ #-} + -- | ITU-R BT.709 color space -instance Elevator e => ColorSpace BT709 D65 e where - type BaseModel BT709 = CM.RGB +instance Elevator e => ColorSpace (BT709 'NonLinear) D65 e where + type BaseModel (BT709 'NonLinear) = CM.RGB toBaseSpace = id {-# INLINE toBaseSpace #-} fromBaseSpace = id @@ -83,9 +99,9 @@ -- | ITU-R BT.709 color space instance RedGreenBlue BT709 D65 where gamut = primaries - ecctf = fmap Rec601.transfer + ecctf = BT709 . fmap Rec601.transfer . coerce {-# INLINE ecctf #-} - dcctf = fmap Rec601.itransfer + dcctf = BT709 . fmap Rec601.itransfer . coerce {-# INLINE dcctf #-} diff --git a/src/Graphics/Color/Space/RGB/Internal.hs b/src/Graphics/Color/Space/RGB/Internal.hs --- a/src/Graphics/Color/Space/RGB/Internal.hs +++ b/src/Graphics/Color/Space/RGB/Internal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,6 +9,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -15,7 +17,7 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Graphics.Color.Space.RGB.Internal --- Copyright : (c) Alexey Kuleshevich 2019 +-- Copyright : (c) Alexey Kuleshevich 2019-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental @@ -25,10 +27,14 @@ ( pattern ColorRGB , pattern ColorRGBA , RedGreenBlue(..) + , Linearity(..) , Gamut(..) , rgb2xyz + , rgbLinear2xyz , xyz2rgb + , xyz2rgbLinear , rgbLuminance + , rgbLinearLuminance , NPM(..) , npmApply , npmDerive @@ -45,42 +51,44 @@ import Graphics.Color.Algebra import qualified Graphics.Color.Model.RGB as CM import Graphics.Color.Space.Internal +import Data.Kind +data Linearity = Linear | NonLinear -class Illuminant i => RedGreenBlue cs (i :: k) | cs -> i where +class Illuminant i => RedGreenBlue (cs :: Linearity -> Type) (i :: k) | cs -> i where -- | RGB primaries that are defined for the RGB color space, while point is defined by -- the __@i@__ type parameter gamut :: RealFloat e => Gamut cs i e -- | Encoding color component transfer function (inverse). Also known as opto-electronic -- transfer function (OETF / OECF) or gamma function. - ecctf :: (RealFloat a, Elevator a) => Color cs a -> Color cs a + ecctf :: (RealFloat a, Elevator a) => Color (cs 'Linear) a -> Color (cs 'NonLinear) a -- | Decoding color component transfer function (forward) - dcctf :: (RealFloat a, Elevator a) => Color cs a -> Color cs a + dcctf :: (RealFloat a, Elevator a) => Color (cs 'NonLinear) a -> Color (cs 'Linear) a -- | Normalized primary matrix for this RGB color space. Default implementation derives -- it from `chromaticity` - npm :: (ColorSpace cs i a, RealFloat a) => NPM cs a + npm :: (ColorSpace (cs 'Linear) i a, RealFloat a) => NPM cs a npm = npmDerive gamut {-# INLINE npm #-} -- | Inverse normalized primary matrix for this RGB color space. Default implementation -- derives it from `chromaticity` - inpm :: (ColorSpace cs i a, RealFloat a) => INPM cs a + inpm :: (ColorSpace (cs 'Linear) i a, RealFloat a) => INPM cs a inpm = inpmDerive gamut {-# INLINE inpm #-} -- | Lift RGB color model into a RGB color space - mkColorRGB :: Color CM.RGB e -> Color cs e + mkColorRGB :: Color CM.RGB e -> Color (cs l) e default mkColorRGB :: - Coercible (Color CM.RGB e) (Color cs e) => Color CM.RGB e -> Color cs e + Coercible (Color CM.RGB e) (Color (cs l) e) => Color CM.RGB e -> Color (cs l) e mkColorRGB = coerce -- | Drop RGB color space down to the RGB color model - unColorRGB :: Color cs e -> Color CM.RGB e + unColorRGB :: Color (cs l) e -> Color CM.RGB e default unColorRGB :: - Coercible (Color cs e) (Color CM.RGB e) => Color cs e -> Color CM.RGB e + Coercible (Color (cs l) e) (Color CM.RGB e) => Color (cs l) e -> Color CM.RGB e unColorRGB = coerce @@ -90,8 +98,16 @@ , gamutBluePrimary :: !(Primary i e) } deriving instance Eq e => Eq (Gamut cs i e) -deriving instance ColorSpace cs i e => Show (Gamut cs i e) -- TODO: better show with whitepoint +instance (RealFloat e, Elevator e, Illuminant i) => Show (Gamut cs i e) where + show Gamut {..} = + unlines + [ "Gamut:" + , " Red: " <> show (primaryChromaticity gamutRedPrimary) + , " Green: " <> show (primaryChromaticity gamutGreenPrimary) + , " Blue: " <> show (primaryChromaticity gamutBluePrimary) + ] + -- | Get the `WhitePoint` of chromaticity. `Chromaticity` itself isn't actually evaluated, -- its type carries enough information for this operation. -- @@ -113,30 +129,35 @@ -- >>> import Graphics.Color.Illuminant.CIE1931 -- >>> import Graphics.Color.Space.RGB.Derived.SRGB -- >>> :{ --- srgbFromLinear :: Color (SRGB 'D65) Float -> Color (XYZ 'D65) Float +-- srgbFromLinear :: Color (SRGB 'D65 'Linear) Float -> Color (XYZ 'D65) Float -- srgbFromLinear = npmApply npm' -- where npm' = trace "Evaluated only once!!!" npm :: NPM (SRGB 'D65) Float -- :} -- -- >>> srgbFromLinear $ ColorRGB 0.1 0.2 0.3 -- +-- 0.16688849, 0.18595251, 0.31085595)> -- >>> srgbFromLinear $ ColorRGB 0.1 0.2 0.3 --- --- >>> rgb = ColorRGB 0.1 0.2 0.3 :: Color (SRGB 'D65) Float +-- +-- >>> rgb = ColorRGB 0.1 0.2 0.3 :: Color (SRGB 'D65 'Linear) Float -- >>> npmApply npm rgb :: Color (XYZ 'D65) Float --- +-- -- -- Here is a comparison with a non-liner sRGB conversion: -- +-- >>> rgb = ColorRGB 0.1 0.2 0.3 :: Color (SRGB 'D65 'NonLinear) Float -- >>> npmApply npm (dcctf rgb) :: Color (XYZ 'D65) Float {- non-linear transformation -} --- +-- -- >>> toColorXYZ rgb :: Color (XYZ 'D65) Float {- non-linear transformation -} --- +-- -- -- -- @since 0.1.0 -npmApply :: (RedGreenBlue cs i, Elevator e) => NPM cs e -> Color cs e -> Color (XYZ i) e +npmApply :: + (RedGreenBlue cs i, Elevator e) + => NPM cs e + -> Color (cs 'Linear) e + -> Color (XYZ i) e npmApply (NPM npm') = coerce . multM3x3byV3 npm' . coerce . unColorRGB {-# INLINE npmApply #-} @@ -144,43 +165,69 @@ -- -- @since 0.1.0 inpmApply :: - (RedGreenBlue cs i, Elevator e) => INPM cs e -> Color (XYZ i) e -> Color cs e + (RedGreenBlue cs i, Elevator e) + => INPM cs e + -> Color (XYZ i) e + -> Color (cs 'Linear) e inpmApply (INPM inpm') = mkColorRGB . coerce . multM3x3byV3 inpm' . coerce {-# INLINE inpmApply #-} -- | Linear transformation of a color into a linear luminance, i.e. the Y component of -- XYZ color space -npmApplyLuminance :: - forall cs i e. (RedGreenBlue cs i, ColorSpace cs i e, RealFloat e) - => Color cs e +rgbLinearLuminance :: + forall cs i e. (RedGreenBlue cs i, ColorSpace (cs 'Linear) i e, RealFloat e) + => Color (cs 'Linear) e -> Color (Y i) e -npmApplyLuminance px = Y (m3x3row1 (unNPM (npm :: NPM cs e)) `dotProduct` coerce (unColorRGB px)) -{-# INLINE npmApplyLuminance #-} +rgbLinearLuminance px = + Y (m3x3row1 (unNPM (npm :: NPM cs e)) `dotProduct` coerce (unColorRGB px)) +{-# INLINE rgbLinearLuminance #-} -rgbLuminance :: (RedGreenBlue cs i, ColorSpace cs i e, RealFloat e) => Color cs e -> Color (Y i) e -rgbLuminance = npmApplyLuminance . dcctf +rgbLuminance :: + (RedGreenBlue cs i, ColorSpace (cs 'Linear) i e, RealFloat e) + => Color (cs 'NonLinear) e + -> Color (Y i) e +rgbLuminance = rgbLinearLuminance . dcctf {-# INLINE rgbLuminance #-} -rgb2xyz :: (RedGreenBlue cs i, ColorSpace cs i e, RealFloat e) => Color cs e -> Color (XYZ i) e +rgb2xyz :: + (RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e, ColorSpace (cs 'Linear) i e, RealFloat e) + => Color (cs 'NonLinear) e + -> Color (XYZ i) e rgb2xyz = npmApply npm . dcctf {-# INLINE rgb2xyz #-} xyz2rgb :: - (RedGreenBlue cs i, ColorSpace cs i e, RealFloat e) + (RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e, ColorSpace (cs 'Linear) i e, RealFloat e) => Color (XYZ i) e - -> Color cs e + -> Color (cs 'NonLinear) e xyz2rgb = ecctf . inpmApply inpm {-# INLINE xyz2rgb #-} + +rgbLinear2xyz :: + (RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e, ColorSpace (cs 'Linear) i e, RealFloat e) + => Color (cs 'Linear) e + -> Color (XYZ i) e +rgbLinear2xyz = npmApply npm +{-# INLINE rgbLinear2xyz #-} + +xyz2rgbLinear :: + forall cs i e. + (RedGreenBlue cs i, ColorSpace (cs 'NonLinear) i e, ColorSpace (cs 'Linear) i e, RealFloat e) + => Color (XYZ i) e + -> Color (cs 'Linear) e +xyz2rgbLinear = inpmApply inpm +{-# INLINE xyz2rgbLinear #-} + -- | Constructor for an RGB color space. -pattern ColorRGB :: RedGreenBlue cs i => e -> e -> e -> Color cs e +pattern ColorRGB :: RedGreenBlue cs i => e -> e -> e -> Color (cs l) e pattern ColorRGB r g b <- (unColorRGB -> CM.ColorRGB r g b) where ColorRGB r g b = mkColorRGB (CM.ColorRGB r g b) {-# COMPLETE ColorRGB #-} -- | Constructor for an RGB color space with Alpha channel -pattern ColorRGBA :: RedGreenBlue cs i => e -> e -> e -> e -> Color (Alpha cs) e +pattern ColorRGBA :: RedGreenBlue cs i => e -> e -> e -> e -> Color (Alpha (cs l)) e pattern ColorRGBA r g b a <- Alpha (unColorRGB -> CM.ColorRGB r g b) a where ColorRGBA r g b a = Alpha (mkColorRGB (CM.ColorRGB r g b)) a {-# COMPLETE ColorRGBA #-} @@ -219,7 +266,7 @@ { unNPM :: M3x3 e } deriving (Eq, Functor, Applicative, Foldable, Traversable) -instance ColorSpace cs i e => Show (NPM cs e) where +instance Elevator e => Show (NPM cs e) where show = show . unNPM -- | Inverse normalized primary matrix (iNPM), which is used to tranform linear @@ -239,7 +286,7 @@ -- -- @since 0.1.0 npmDerive :: - forall cs i e. (ColorSpace cs i e, RealFloat e) + forall cs i e. (ColorSpace (cs 'Linear) i e, RealFloat e) => Gamut cs i e -> NPM cs e npmDerive (Gamut r g b) = NPM (primaries' * M3x3 coeff coeff coeff) @@ -258,7 +305,7 @@ -- -- @since 0.1.0 inpmDerive :: - forall cs i e. (ColorSpace cs i e, RealFloat e) + forall cs i e. (ColorSpace (cs 'Linear) i e, RealFloat e) => Gamut cs i e -> INPM cs e inpmDerive = INPM . invertM3x3 . unNPM . npmDerive @@ -270,7 +317,7 @@ -- evaluated, its type carries enough information for this operation. -- -- @since 0.1.0 -rgbColorGamut :: (RedGreenBlue cs i, RealFloat e) => Color cs a -> Gamut cs i e +rgbColorGamut :: (RedGreenBlue cs i, RealFloat e) => Color (cs l) a -> Gamut cs i e rgbColorGamut _ = gamut {-# INLINE rgbColorGamut #-} @@ -281,14 +328,12 @@ -- >>> import Graphics.Color.Space.RGB -- >>> :set -XTypeApplications -- >>> pixelWhitePoint @Float (ColorSRGB @Word8 1 2 3) --- WhitePoint (Chromaticity ) --- >>> Just (pixelWhitePoint @Float (ColorSRGB @Word8 1 2 3)) --- Just (WhitePoint (Chromaticity )) +-- WhitePoint (Chromaticity {chromaticityCIExyY = }) -- -- @since 0.1.0 pixelWhitePoint :: - forall e cs a i. (RedGreenBlue cs i, RealFloat e) - => Color cs a + forall e cs a i l. (RedGreenBlue cs i, RealFloat e) + => Color (cs l) a -> WhitePoint i e pixelWhitePoint _ = whitePoint {-# INLINE pixelWhitePoint #-} diff --git a/src/Graphics/Color/Space/RGB/Luma.hs b/src/Graphics/Color/Space/RGB/Luma.hs --- a/src/Graphics/Color/Space/RGB/Luma.hs +++ b/src/Graphics/Color/Space/RGB/Luma.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} @@ -31,6 +32,7 @@ , rgbLumaWeights ) where +import Data.Kind import Data.Coerce import Foreign.Storable import Graphics.Color.Model.RGB as CM @@ -96,7 +98,7 @@ -- Luma Weights -- ------------------ -class Luma cs where +class Luma (cs :: Linearity -> Type) where {-# MINIMAL (rWeight, gWeight)|(rWeight, bWeight)|(gWeight, bWeight) #-} rWeight :: RealFloat e => Weight cs e rWeight = 1 - bWeight - gWeight @@ -119,7 +121,7 @@ -- @since 0.1.4 rgbLumaWeights :: forall cs e' e. (Luma cs, RealFloat e) - => Color cs e' + => Color (cs 'NonLinear) e' -> Weights e rgbLumaWeights _ = Weights (V3 (coerce (rWeight :: Weight cs e) :: e) @@ -132,7 +134,7 @@ -- @since 0.1.0 rgbLuma :: forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e) - => Color cs e' + => Color (cs 'NonLinear) e' -> Color Y' e rgbLuma rgb' = Y' (coerce (fmap toRealFloat rgb :: Color CM.RGB e) `dotProduct` coerce weights) where diff --git a/src/Graphics/Color/Space/RGB/SRGB.hs b/src/Graphics/Color/Space/RGB/SRGB.hs --- a/src/Graphics/Color/Space/RGB/SRGB.hs +++ b/src/Graphics/Color/Space/RGB/SRGB.hs @@ -32,71 +32,88 @@ , itransfer ) where +import Data.Coerce +import Data.Typeable import Foreign.Storable +import Graphics.Color.Illuminant.ICC.PCS (D50) import Graphics.Color.Model.Internal import qualified Graphics.Color.Model.RGB as CM import Graphics.Color.Space.Internal import Graphics.Color.Space.RGB.Internal -import Graphics.Color.Space.RGB.Luma -import Graphics.Color.Illuminant.ICC.PCS (D50) import Graphics.Color.Space.RGB.ITU.Rec709 (D65, primaries) +import Graphics.Color.Space.RGB.Luma -- | The most common [sRGB](https://en.wikipedia.org/wiki/SRGB) color space with the -- default `D65` illuminant -data SRGB +data SRGB (l :: Linearity) -newtype instance Color SRGB e = SRGB (Color CM.RGB e) +newtype instance Color (SRGB l) e = SRGB (Color CM.RGB e) -- | Constructor for a color in @sRGB@ color space -- -- @since 0.1.0 -pattern ColorSRGB :: e -> e -> e -> Color SRGB e +pattern ColorSRGB :: e -> e -> e -> Color (SRGB l) e pattern ColorSRGB r g b = SRGB (CM.ColorRGB r g b) {-# COMPLETE ColorSRGB #-} -- | Constructor for a color in @sRGB@ color space with alphs channel -- -- @since 0.1.0 -pattern ColorSRGBA :: e -> e -> e -> e -> Color (Alpha SRGB) e +pattern ColorSRGBA :: e -> e -> e -> e -> Color (Alpha (SRGB l)) e pattern ColorSRGBA r g b a = Alpha (SRGB (CM.ColorRGB r g b)) a {-# COMPLETE ColorSRGBA #-} --- | s`RGB` color space -deriving instance Eq e => Eq (Color SRGB e) --- | s`RGB` color space -deriving instance Ord e => Ord (Color SRGB e) --- | s`RGB` color space -deriving instance Functor (Color SRGB) --- | s`RGB` color space -deriving instance Applicative (Color SRGB) --- | s`RGB` color space -deriving instance Foldable (Color SRGB) --- | s`RGB` color space -deriving instance Traversable (Color SRGB) --- | s`RGB` color space -deriving instance Storable e => Storable (Color SRGB e) +-- | `SRGB` color space +deriving instance Eq e => Eq (Color (SRGB l) e) +-- | `SRGB` color space +deriving instance Ord e => Ord (Color (SRGB l) e) +-- | `SRGB` color space +deriving instance Functor (Color (SRGB l)) +-- | `SRGB` color space +deriving instance Applicative (Color (SRGB l)) +-- | `SRGB` color space +deriving instance Foldable (Color (SRGB l)) +-- | `SRGB` color space +deriving instance Traversable (Color (SRGB l)) +-- | `SRGB` color space +deriving instance Storable e => Storable (Color (SRGB l) e) --- | s`RGB` color space -instance Elevator e => Show (Color SRGB e) where +-- | `SRGB` color space +instance (Typeable l, Elevator e) => Show (Color (SRGB l) e) where showsPrec _ = showsColorModel --- | s`RGB` color space -instance Elevator e => ColorModel SRGB e where - type Components SRGB e = (e, e, e) +-- | `SRGB` color space +instance (Typeable l, Elevator e) => ColorModel (SRGB l) e where + type Components (SRGB l) e = (e, e, e) toComponents = toComponents . unColorRGB {-# INLINE toComponents #-} fromComponents = mkColorRGB . fromComponents {-# INLINE fromComponents #-} --- | s`RGB` color space -instance Elevator e => ColorSpace SRGB D65 e where - type BaseModel SRGB = CM.RGB +-- | `SRGB` linear color space +instance Elevator e => ColorSpace (SRGB 'Linear) D65 e where + type BaseModel (SRGB 'Linear) = CM.RGB toBaseSpace = id {-# INLINE toBaseSpace #-} fromBaseSpace = id {-# INLINE fromBaseSpace #-} + luminance = rgbLinearLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgbLinear2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgbLinear + {-# INLINE fromColorXYZ #-} + + +-- | `SRGB` linear color space +instance Elevator e => ColorSpace (SRGB 'NonLinear) D65 e where + type BaseModel (SRGB 'NonLinear) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} luminance = rgbLuminance . fmap toRealFloat {-# INLINE luminance #-} toColorXYZ = rgb2xyz . fmap toRealFloat @@ -104,14 +121,14 @@ fromColorXYZ = fmap fromRealFloat . xyz2rgb {-# INLINE fromColorXYZ #-} --- | s`RGB` color space +-- | `SRGB` color space instance RedGreenBlue SRGB D65 where gamut = primaries npm = npmStandard inpm = inpmStandard - ecctf = fmap transfer + ecctf = SRGB . fmap transfer . coerce {-# INLINE ecctf #-} - dcctf = fmap itransfer + dcctf = SRGB . fmap itransfer . coerce {-# INLINE dcctf #-} instance Luma SRGB where @@ -125,9 +142,9 @@ -- >>> :set -XDataKinds -- >>> import Graphics.Color.Space.RGB -- >>> npmStandard :: NPM SRGB Float --- [ [ 0.412400, 0.357600, 0.180500 ] --- , [ 0.212600, 0.715200, 0.072200 ] --- , [ 0.019300, 0.119200, 0.950500 ] ] +-- [ [ 0.41240000, 0.35760000, 0.18050000 ] +-- , [ 0.21260000, 0.71520000, 0.07220000 ] +-- , [ 0.01930000, 0.11920000, 0.95050000 ] ] -- -- @since 0.1.0 npmStandard :: RealFloat a => NPM SRGB a @@ -141,9 +158,9 @@ -- >>> :set -XDataKinds -- >>> import Graphics.Color.Space.RGB -- >>> inpmStandard :: INPM SRGB Float --- [ [ 3.240600,-1.537200,-0.498600 ] --- , [-0.968900, 1.875800, 0.041500 ] --- , [ 0.055700,-0.204000, 1.057000 ] ] +-- [ [ 3.24060000,-1.53720000,-0.49860000 ] +-- , [-0.96890000, 1.87580000, 0.04150000 ] +-- , [ 0.05570000,-0.20400000, 1.05700000 ] ] -- -- @since 0.1.0 inpmStandard :: RealFloat a => INPM SRGB a diff --git a/src/Graphics/Pixel/ColorSpace.hs b/src/Graphics/Pixel/ColorSpace.hs --- a/src/Graphics/Pixel/ColorSpace.hs +++ b/src/Graphics/Pixel/ColorSpace.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} @@ -39,6 +40,8 @@ , toPixelF , toPixelD -- * RGB + , toPixelLinearRGB + , fromPixelLinearRGB -- ** sRGB color space , pattern PixelSRGB , pattern PixelSRGBA @@ -69,12 +72,13 @@ -- | Convert a pixel from one color space to any other. -- +-- >>> :set -XDataKinds -- >>> :set -XTypeApplications -- >>> px = PixelSRGB @Float 0.0 0.5 1.0 -- >>> px --- --- >>> convertPixel @AdobeRGB @_ @Word8 px --- +-- +-- >>> convertPixel @(AdobeRGB 'NonLinear) @_ @Word8 px +-- -- -- @since 0.1.0 convertPixel :: @@ -87,14 +91,14 @@ -- | Constructor for a pixel in @sRGB@ color space -- -- @since 0.1.0 -pattern PixelSRGB :: e -> e -> e -> Pixel SRGB e +pattern PixelSRGB :: e -> e -> e -> Pixel (SRGB 'NonLinear) 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) e +pattern PixelSRGBA :: e -> e -> e -> e -> Pixel (Alpha (SRGB 'NonLinear)) e pattern PixelSRGBA r g b a = Pixel (Alpha (SRGB (CM.ColorRGB r g b)) a) {-# COMPLETE PixelSRGBA #-} @@ -130,7 +134,7 @@ -- | Constructor for a pixel in RGB color space. -- -- @since 0.1.0 -pattern PixelRGB :: RedGreenBlue cs (i :: k) => e -> e -> e -> Pixel cs e +pattern PixelRGB :: RedGreenBlue cs (i :: k) => e -> e -> e -> Pixel (cs l) e pattern PixelRGB r g b <- (coerce . unColorRGB . coerce -> V3 r g b) where PixelRGB r g b = coerce (mkColorRGB (coerce (V3 r g b))) {-# COMPLETE PixelRGB #-} @@ -191,7 +195,7 @@ -- | Constructor for a pixel in RGB color space with Alpha channel -- -- @since 0.1.0 -pattern PixelRGBA :: RedGreenBlue cs i => e -> e -> e -> e -> Pixel (Alpha cs) e +pattern PixelRGBA :: RedGreenBlue cs i => e -> e -> e -> e -> Pixel (Alpha (cs l)) e pattern PixelRGBA r g b a <- (pixelColor -> Alpha (unColorRGB -> CM.ColorRGB r g b) a) where PixelRGBA r g b a = Pixel (Alpha (mkColorRGB (CM.ColorRGB r g b)) a) {-# COMPLETE PixelRGBA #-} @@ -235,12 +239,28 @@ pattern PixelYCbCrA y cb cr a = Pixel (ColorYCbCrA y cb cr a) {-# COMPLETE PixelYCbCrA #-} +-- | Convert non-linear RGB color space into linear one +-- +-- @since 0.2.0 +toPixelLinearRGB :: + (RedGreenBlue cs i, Elevator e, RealFloat e) => Pixel (cs 'NonLinear) e -> Pixel (cs 'Linear) e +toPixelLinearRGB = liftPixel dcctf +{-# INLINE toPixelLinearRGB #-} + +-- | Convert linear RGB color space into a non-linear one +-- +-- @since 0.2.0 +fromPixelLinearRGB :: + (RedGreenBlue cs i, Elevator e, RealFloat e) => Pixel (cs 'Linear) e -> Pixel (cs 'NonLinear) e +fromPixelLinearRGB = liftPixel ecctf +{-# INLINE fromPixelLinearRGB #-} + -- | Convert an RGB pixel to `Y'` if it has the weights specified with `Luma`. -- -- @since 0.1.4 rgbPixelLuma :: forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e) - => Pixel cs e' + => Pixel (cs 'NonLinear) e' -> Pixel Y' e rgbPixelLuma = liftPixel rgbLuma diff --git a/src/Graphics/Pixel/Internal.hs b/src/Graphics/Pixel/Internal.hs --- a/src/Graphics/Pixel/Internal.hs +++ b/src/Graphics/Pixel/Internal.hs @@ -33,6 +33,7 @@ import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as VM import qualified Data.Vector.Unboxed as VU +import Data.Default.Class (Default) -- | Digital imaging is one of the most common places for a color to be used in. The -- smallest element in any image is a pixel, which is defined by its color. @@ -57,6 +58,7 @@ deriving instance Foldable (Color cs) => Foldable (Pixel cs) deriving instance Traversable (Color cs) => Traversable (Pixel cs) deriving instance Storable (Color cs e) => Storable (Pixel cs e) +deriving instance Default (Color cs e) => Default (Pixel cs e) instance Show (Color cs e) => Show (Pixel cs e) where show = show . pixelColor diff --git a/tests/Graphics/Color/Space/CIE1931/RGBSpec.hs b/tests/Graphics/Color/Space/CIE1931/RGBSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Space/CIE1931/RGBSpec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Space.CIE1931.RGBSpec (spec) where + +import Graphics.Color.Space.CIE1931.RGB +import Graphics.Color.Space.Common + +instance (Elevator e, Random e) => Arbitrary (Color (CIERGB l) e) where + arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + +spec :: Spec +spec = describe "RGB" $ do + colorModelSpec @(CIERGB 'NonLinear) @Word "CIERGB 'NonLinear" + colorSpaceSpec @(CIERGB 'NonLinear) @Float + colorModelSpec @(CIERGB 'Linear) @Int "CIERGB 'Linear" + colorSpaceSpec @(CIERGB 'Linear) @Double diff --git a/tests/Graphics/Color/Space/CIE1976/LABSpec.hs b/tests/Graphics/Color/Space/CIE1976/LABSpec.hs --- a/tests/Graphics/Color/Space/CIE1976/LABSpec.hs +++ b/tests/Graphics/Color/Space/CIE1976/LABSpec.hs @@ -28,9 +28,9 @@ prop "lab2srgb" $ \lab@(ColorLAB l' a' b' :: Color (LAB 'W.D65) Double) -> case Colour.toSRGB (Colour.cieLAB Colour.d65 l' a' b') of Colour.RGB r g b -> - (convertColor lab :: Color (SRGB 'W.D65) Double) + (convertColor lab :: Color (SRGB 'W.D65 'NonLinear) Double) `epsilonEqColorDouble` ColorRGB r g b - prop "srgb2xlab" $ \rgb@(ColorRGB r g b :: Color (SRGB 'W.D65) Double) -> + prop "srgb2xlab" $ \rgb@(ColorRGB r g b :: Color (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) diff --git a/tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs b/tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs --- a/tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs +++ b/tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} module Graphics.Color.Space.RGB.AdobeRGBSpec (spec, arbitraryElevator) where @@ -5,11 +6,12 @@ import Graphics.Color.Space.Common import Graphics.Color.Space.RGB.AdobeRGB -instance (Elevator e, Random e) => Arbitrary (Color AdobeRGB e) where +instance (Elevator e, Random e) => Arbitrary (Color (AdobeRGB l) e) where arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator spec :: Spec spec = describe "AdobeRGB" $ do - colorModelSpec @AdobeRGB @Word "AdobeRGB" - colorSpaceLenientSpec @AdobeRGB @Float 0.00001 + colorModelSpec @(AdobeRGB 'NonLinear) @Word "AdobeRGB 'NonLinear" + colorSpaceLenientSpec @(AdobeRGB 'NonLinear) @Float 0.00001 + colorSpaceLenientSpec @(AdobeRGB 'Linear) @Double 0.00001 diff --git a/tests/Graphics/Color/Space/RGB/Alternative/CMYKSpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/CMYKSpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/CMYKSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/CMYKSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -18,9 +19,9 @@ spec :: Spec spec = describe "CMYK" $ do - colorModelSpec @(CMYK (Derived.SRGB D65)) @Word "CMYK" - colorSpaceCommonSpec @(CMYK (Derived.SRGB D65)) @Double $ pure () + colorModelSpec @(CMYK (Derived.SRGB D65 'NonLinear)) @Word "CMYK" + colorSpaceCommonSpec @(CMYK (Derived.SRGB D65 'NonLinear)) @Double $ pure () -- Arbitrary inverse CMYKtoSRGB is not true. - prop "sRGBtoCMYK" $ \ (srgb :: Color (Derived.SRGB D65) Double) -> - toBaseSpace (fromBaseSpace srgb :: Color (CMYK (Derived.SRGB D65)) Double) + prop "sRGBtoCMYK" $ \ (srgb :: Color (Derived.SRGB D65 'NonLinear) Double) -> + toBaseSpace (fromBaseSpace srgb :: Color (CMYK (Derived.SRGB D65 'NonLinear)) Double) `epsilonEqColor` srgb diff --git a/tests/Graphics/Color/Space/RGB/Alternative/HSISpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/HSISpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/HSISpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/HSISpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} module Graphics.Color.Space.RGB.Alternative.HSISpec (spec) where @@ -17,5 +18,5 @@ spec = describe "HSI" $ do describe "Derived-sRGB" $ do - colorModelSpec @(HSI (Derived.SRGB D65)) @Word "HSI" - colorSpaceSpec @(HSI (Derived.SRGB D65)) @Double + colorModelSpec @(HSI (Derived.SRGB D65 'NonLinear)) @Word "HSI" + colorSpaceSpec @(HSI (Derived.SRGB D65 'NonLinear)) @Double diff --git a/tests/Graphics/Color/Space/RGB/Alternative/HSLSpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/HSLSpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/HSLSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/HSLSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} module Graphics.Color.Space.RGB.Alternative.HSLSpec (spec) where @@ -17,5 +18,5 @@ spec = describe "HSL" $ do describe "Derived-sRGB" $ do - colorModelSpec @(HSL (Derived.SRGB D65)) @Word "HSL" - colorSpaceSpec @(HSL (Derived.SRGB D65)) @Double + colorModelSpec @(HSL (Derived.SRGB D65 'NonLinear)) @Word "HSL" + colorSpaceSpec @(HSL (Derived.SRGB D65 'NonLinear)) @Double diff --git a/tests/Graphics/Color/Space/RGB/Alternative/HSVSpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/HSVSpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/HSVSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/HSVSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} module Graphics.Color.Space.RGB.Alternative.HSVSpec (spec) where @@ -17,5 +18,7 @@ spec = describe "HSV" $ do describe "Derived-sRGB" $ do - colorModelSpec @(HSV (Derived.SRGB D65)) @Word "HSV" - colorSpaceSpec @(HSV (Derived.SRGB D65)) @Double + colorModelSpec @(HSV (Derived.SRGB D65 'NonLinear)) @Word "HSV" + colorSpaceSpec @(HSV (Derived.SRGB D65 'NonLinear)) @Double + colorModelSpec @(HSV (Derived.SRGB D65 'Linear)) @Int "HSV" + colorSpaceSpec @(HSV (Derived.SRGB D65 'Linear)) @Float diff --git a/tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -23,26 +24,26 @@ spec = describe "YCbCr" $ do describe "sRGB" $ do - colorModelSpec @(YCbCr SRGB) @Word "YCbCr" - colorSpaceCommonSpec @(YCbCr SRGB) @Double $ pure () + colorModelSpec @(YCbCr (SRGB 'NonLinear)) @Word "YCbCr" + colorSpaceCommonSpec @(YCbCr (SRGB 'NonLinear)) @Double $ pure () describe "Derived-sRGB" $ do - colorModelSpec @(YCbCr (Derived.SRGB D65)) @Word "YCbCr" - colorSpaceCommonSpec @(YCbCr (Derived.SRGB D65)) @Double $ pure () - prop "toColorYCbCr . toColorYCbCr" $ \(rgb :: Color (Derived.SRGB D65) Double) -> + colorModelSpec @(YCbCr (Derived.SRGB D65 'NonLinear)) @Word "YCbCr" + colorSpaceCommonSpec @(YCbCr (Derived.SRGB D65 'NonLinear)) @Double $ pure () + prop "toColorYCbCr . toColorYCbCr" $ \(rgb :: Color (Derived.SRGB D65 'NonLinear) Double) -> rgb `epsilonEqColor` - fromColorYCbCr (toColorYCbCr rgb :: Color (YCbCr (Derived.SRGB D65)) Double) - prop "toColorYCbCr == srgb2ycbcr" $ \(rgb :: Color SRGB Double) -> + fromColorYCbCr (toColorYCbCr rgb :: Color (YCbCr (Derived.SRGB D65 'NonLinear)) Double) + prop "toColorYCbCr == srgb2ycbcr" $ \(rgb :: Color (SRGB 'NonLinear) Double) -> srgb2ycbcr rgb `epsilonEqColor` - (toColorYCbCr rgb :: Color (YCbCr SRGB) Double) - prop "fromColorYCbCr == ycbcr2srgb" $ \(ycbcr :: Color (YCbCr SRGB) Double) -> - ycbcr2srgb ycbcr `epsilonEqColor` (fromColorYCbCr ycbcr :: Color SRGB Double) + (toColorYCbCr rgb :: Color (YCbCr (SRGB 'NonLinear)) Double) + prop "fromColorYCbCr == ycbcr2srgb" $ \(ycbcr :: Color (YCbCr (SRGB 'NonLinear)) Double) -> + ycbcr2srgb ycbcr `epsilonEqColor` (fromColorYCbCr ycbcr :: Color (SRGB 'NonLinear) Double) describe "Match JuicyPixels" $ do - prop "rgb2ycbcr" $ \(rgb@(ColorRGB r g b) :: Color SRGB Word8) -> + prop "rgb2ycbcr" $ \(rgb@(ColorRGB r g b) :: Color (SRGB 'NonLinear) Word8) -> case JuicyPixels.convertPixel (JuicyPixels.PixelRGB8 r g b) of JuicyPixels.PixelYCbCr8 y cb cr -> - (fromBaseSpace rgb :: Color (YCbCr SRGB) Word8) + (fromBaseSpace rgb :: Color (YCbCr (SRGB 'NonLinear)) Word8) `approxIntegralColorExpect1` ColorYCbCr y cb cr - prop "ycbcr2rgb" $ \(ycbcr@(ColorYCbCr y cb cr) :: Color (YCbCr SRGB) Word8) -> + prop "ycbcr2rgb" $ \(ycbcr@(ColorYCbCr y cb cr) :: Color (YCbCr (SRGB 'NonLinear)) Word8) -> case JuicyPixels.convertPixel (JuicyPixels.PixelYCbCr8 y cb cr) of JuicyPixels.PixelRGB8 r g b -> (toBaseSpace ycbcr) `approxIntegralColorExpect1` ColorRGB r g b diff --git a/tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs b/tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs --- a/tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs @@ -10,11 +10,13 @@ import Graphics.Color.Space.Common import Graphics.Color.Space.RGB.Derived.AdobeRGB -instance (Elevator e, Random e, Illuminant i) => Arbitrary (Color (AdobeRGB (i :: k)) e) where +instance (Elevator e, Random e, Illuminant i) => Arbitrary (Color (AdobeRGB (i :: k) l) e) where arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator spec :: Spec spec = describe "AdobeRGB" $ do - colorModelSpec @(AdobeRGB 'D65) @Word "AdobeRGB" - colorSpaceSpec @(AdobeRGB 'D65) @Float + colorModelSpec @(AdobeRGB 'D65 'NonLinear) @Word "AdobeRGB CIE1931 'D65 'NonLinear" + colorSpaceSpec @(AdobeRGB 'D65 'NonLinear) @Float + colorModelSpec @(AdobeRGB 'D50 'Linear) @Int "AdobeRGB CIE1931 'D50 'Linear" + colorSpaceSpec @(AdobeRGB 'D50 'Linear) @Double diff --git a/tests/Graphics/Color/Space/RGB/Derived/CIERGBSpec.hs b/tests/Graphics/Color/Space/RGB/Derived/CIERGBSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Space/RGB/Derived/CIERGBSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Space.RGB.Derived.CIERGBSpec (spec) where + +import Graphics.Color.Illuminant.CIE1931 +import Graphics.Color.Space.RGB.Derived.CIERGB +import Graphics.Color.Space.Common + +instance (Elevator e, Random e, Illuminant i) => Arbitrary (Color (CIERGB (i :: k) l) e) where + arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + +spec :: Spec +spec = describe "RGB" $ do + colorModelSpec @(CIERGB 'E 'NonLinear) @Word "CIERGB CIE1931 'E 'NonLinear" + colorSpaceSpec @(CIERGB 'E 'NonLinear) @Float + colorModelSpec @(CIERGB 'D75 'Linear) @Int "CIERGB CIE1931 'D75 'Linear" + colorSpaceSpec @(CIERGB 'D75 'Linear) @Double diff --git a/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs b/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs --- a/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs @@ -14,29 +14,33 @@ import Graphics.Color.Space.Common import Graphics.Color.Space.RGB.Derived.SRGB -instance (Elevator e, Random e, Illuminant i) => Arbitrary (Color (SRGB (i :: k)) e) where +instance (Elevator e, Random e, Illuminant i) => Arbitrary (Color (SRGB (i :: k) l) e) where arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator spec :: Spec spec = describe "SRGB" $ do - colorModelSpec @(SRGB 'D65) @Word "SRGB" - colorSpaceSpec @(SRGB 'D65) @Float + colorModelSpec @(SRGB 'D65 'NonLinear) @Word "SRGB CIE1931 'D65 'NonLinear" + colorSpaceSpec @(SRGB 'D65 'NonLinear) @Float + colorModelSpec @(SRGB 'D55 'Linear) @Int "SRGB CIE1931 'D55 'Linear" + colorSpaceSpec @(SRGB 'D55 'Linear) @Double describe "Same as colour package" $ do prop "xyz2srgb" $ \xyz@(ColorXYZ x y z :: Color (XYZ 'W.D65) Double) -> case Colour.toSRGB (Colour.cieXYZ x y z) of Colour.RGB r g b -> - (fromColorXYZ xyz :: Color (SRGB 'W.D65) Double) `epsilonEqColorDouble` ColorRGB r g b - prop "xyz2linearsrgb" $ \xyz@(ColorXYZ x y z :: Color (XYZ 'W.D65) Double) -> + (fromColorXYZ xyz :: Color (SRGB 'W.D65 'NonLinear) Double) + `epsilonEqColorDouble` + ColorRGB r g b + prop "xyz2linearsrgb" $ \xyz@(ColorXYZ x y z :: Color (XYZ 'W.D65 ) Double) -> case Colour.toRGB (Colour.cieXYZ x y z) of Colour.RGB r g b -> - dcctf (fromColorXYZ xyz :: Color (SRGB 'W.D65) Double) `epsilonEqColorDouble` + dcctf (fromColorXYZ xyz :: Color (SRGB 'W.D65 'NonLinear) Double) `epsilonEqColorDouble` ColorRGB r g b - prop "srgb2xyz" $ \rgb@(ColorRGB r g b :: Color (SRGB 'W.D65) Double) -> + prop "srgb2xyz" $ \rgb@(ColorRGB r g b :: Color (SRGB 'W.D65 'NonLinear) Double) -> case Colour.cieXYZView (Colour.sRGB r g b) of (x, y, z) -> toColorXYZ rgb `epsilonEqColorDouble` ColorXYZ x y z - prop "linersrgb2xyz" $ \rgb@(ColorRGB r g b :: Color (SRGB 'W.D65) Double) -> + prop "linersrgb2xyz" $ \rgb@(ColorRGB r g b :: Color (SRGB 'W.D65 'Linear) Double) -> case Colour.cieXYZView (Colour.rgb r g b) of (x, y, z) -> toColorXYZ (ecctf rgb) `epsilonEqColorDouble` ColorXYZ x y z diff --git a/tests/Graphics/Color/Space/RGB/ITU/Rec470Spec.hs b/tests/Graphics/Color/Space/RGB/ITU/Rec470Spec.hs --- a/tests/Graphics/Color/Space/RGB/ITU/Rec470Spec.hs +++ b/tests/Graphics/Color/Space/RGB/ITU/Rec470Spec.hs @@ -7,18 +7,22 @@ import Graphics.Color.Space.Common import Graphics.Color.Space.RGB.ITU.Rec470 -instance (Elevator e, Random e) => Arbitrary (Color BT470_525 e) where +instance (Elevator e, Random e) => Arbitrary (Color (BT470_525 l) e) where arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator -instance (Elevator e, Random e) => Arbitrary (Color BT470_625 e) where +instance (Elevator e, Random e) => Arbitrary (Color (BT470_625 l) e) where arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator spec :: Spec spec = do describe "Rec470 (525)" $ do - colorModelSpec @BT470_525 @Word "BT470_525" - colorSpaceSpec @BT470_525 @Float + colorModelSpec @(BT470_525 'NonLinear) @Word "BT470_525 'NonLinear" + colorSpaceSpec @(BT470_525 'NonLinear) @Float + colorModelSpec @(BT470_525 'Linear) @Word8 "BT470_525 'Linear" + colorSpaceSpec @(BT470_525 'Linear) @Double describe "Rec470 (625)" $ do - colorModelSpec @BT470_625 @Word "BT470_625" - colorSpaceSpec @BT470_625 @Float + colorModelSpec @(BT470_625 'NonLinear) @Word "BT470_625 'NonLinear" + colorSpaceSpec @(BT470_625 'NonLinear) @Float + colorModelSpec @(BT470_625 'Linear) @Word16 "BT470_625 'Linear" + colorSpaceSpec @(BT470_625 'Linear) @Double diff --git a/tests/Graphics/Color/Space/RGB/ITU/Rec601Spec.hs b/tests/Graphics/Color/Space/RGB/ITU/Rec601Spec.hs --- a/tests/Graphics/Color/Space/RGB/ITU/Rec601Spec.hs +++ b/tests/Graphics/Color/Space/RGB/ITU/Rec601Spec.hs @@ -7,18 +7,20 @@ import Graphics.Color.Space.Common import Graphics.Color.Space.RGB.ITU.Rec601 -instance (Elevator e, Random e) => Arbitrary (Color BT601_525 e) where +instance (Elevator e, Random e) => Arbitrary (Color (BT601_525 l) e) where arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator -instance (Elevator e, Random e) => Arbitrary (Color BT601_625 e) where +instance (Elevator e, Random e) => Arbitrary (Color (BT601_625 l) e) where arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator spec :: Spec spec = do describe "Rec601 (525)" $ do - colorModelSpec @BT601_525 @Word "BT601_525" - colorSpaceSpec @BT601_525 @Float + colorModelSpec @(BT601_525 'NonLinear) @Word "BT601_525" + colorSpaceSpec @(BT601_525 'NonLinear) @Float + colorSpaceSpec @(BT601_525 'Linear) @Double describe "Rec601 (625)" $ do - colorModelSpec @BT601_625 @Word "BT601_625" - colorSpaceSpec @BT601_625 @Float + colorModelSpec @(BT601_625 'NonLinear) @Word "BT601_625" + colorSpaceSpec @(BT601_625 'NonLinear) @Float + colorSpaceSpec @(BT601_625 'Linear) @Double diff --git a/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs b/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs --- a/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs +++ b/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs @@ -7,12 +7,13 @@ import Graphics.Color.Space.Common import Graphics.Color.Space.RGB.ITU.Rec709 -instance (Elevator e, Random e) => Arbitrary (Color BT709 e) where +instance (Elevator e, Random e) => Arbitrary (Color (BT709 l) e) where arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator spec :: Spec spec = describe "Rec709" $ do - colorModelSpec @BT709 @Word "BT709" + colorModelSpec @(BT709 'NonLinear) @Word "BT709" -- Roundrtrip is not always very accurate, eg: 8.115324539550295e-2 /= 8.140132075907752e-2 - colorSpaceLenientSpec @BT709 @Float 5e-4 + colorSpaceLenientSpec @(BT709 'NonLinear) @Float 5e-4 + colorSpaceLenientSpec @(BT709 'Linear) @Double 5e-4 diff --git a/tests/Graphics/Color/Space/RGB/SRGBSpec.hs b/tests/Graphics/Color/Space/RGB/SRGBSpec.hs --- a/tests/Graphics/Color/Space/RGB/SRGBSpec.hs +++ b/tests/Graphics/Color/Space/RGB/SRGBSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeApplications #-} module Graphics.Color.Space.RGB.SRGBSpec (spec, arbitraryElevator) where @@ -5,11 +6,13 @@ import Graphics.Color.Space.Common import Graphics.Color.Space.RGB.SRGB -instance (Elevator e, Random e) => Arbitrary (Color SRGB e) where +instance (Elevator e, Random e) => Arbitrary (Color (SRGB l) e) where arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator spec :: Spec spec = describe "SRGB" $ do - colorModelSpec @SRGB @Word "SRGB" - colorSpaceLenientSpec @SRGB @Float 0.001 + colorModelSpec @(SRGB 'NonLinear) @Word "SRGB 'NonLinear" + colorSpaceLenientSpec @(SRGB 'NonLinear) @Float 0.001 + colorModelSpec @(SRGB 'Linear) @Word "SRGB 'Linear" + colorSpaceLenientSpec @(SRGB 'Linear) @Double 0.001 diff --git a/tests/Graphics/Color/Standard/RALSpec.hs b/tests/Graphics/Color/Standard/RALSpec.hs --- a/tests/Graphics/Color/Standard/RALSpec.hs +++ b/tests/Graphics/Color/Standard/RALSpec.hs @@ -1178,7 +1178,10 @@ ] -ralAlternatives :: [(Color SRGB Word8, Color (HSL SRGB) Float, Color (CMYK SRGB) Word8)] +ralAlternatives :: + [( Color (SRGB 'NonLinear) Word8 + , Color (HSL (SRGB 'NonLinear)) Float + , Color (CMYK (SRGB 'NonLinear)) Word8)] ralAlternatives = [ (ColorRGB r g b, ColorH360SL h (s / 100) (l / 100), ColorCMYK c m y k) | (_y', r, g, b, h, s, l, c, m, y, k) <- ralAlternativeRaw @@ -1402,7 +1405,7 @@ , (122.57, 121, 123, 123, 0.50, 0.82, 47.84, 2, 0, 0, 52) ] -_hexes :: [Color SRGB Word8] +_hexes :: [Color (SRGB 'NonLinear) Word8] _hexes = [ fromIntegral <$> fromComponents (shiftR (x .&. 0xFF0000) 16, shiftR (x .&. 0xFF00) 8, x .&. 0xFF) diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,10 +1,11 @@ module Main where import Spec -import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout) +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) import Test.Hspec main :: IO () main = do hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 hspec spec diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -1,12 +1,6 @@ module Main where -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) import Test.DocTest (doctest) main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources +main = doctest ["src"]