diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for color + +## 0.0.0 + +Initial alpha release diff --git a/Color.cabal b/Color.cabal new file mode 100644 --- /dev/null +++ b/Color.cabal @@ -0,0 +1,173 @@ +name: Color +version: 0.1.0 +synopsis: Common color spaces and conversions between them +description: Please see the README on GitHub at +homepage: https://github.com/lehins/color +license: BSD3 +license-file: LICENSE +author: Alexey Kuleshevich +maintainer: alexey@kuleshevi.ch +copyright: 2019-2020 Alexey Kuleshevich +category: Graphics +extra-source-files: README.md + , CHANGELOG.md +cabal-version: >=1.10 +build-type: Custom +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 + +custom-setup + setup-depends: + base + , Cabal + , cabal-doctest >=1.0.6 + +library + hs-source-dirs: src + exposed-modules: Graphics.Color.Algebra + , Graphics.Color.Algebra.Binary + , Graphics.Color.Adaptation + , Graphics.Color.Adaptation.VonKries + -- , Graphics.Color.Adaptation.CIE1994 + -- , Graphics.Color.Adaptation.CMCCAT2000 + -- , Graphics.Color.Adaptation.Fairchild + , Graphics.Color.Illuminant.CIE1931 + , Graphics.Color.Illuminant.CIE1964 + , Graphics.Color.Illuminant.ICC.PCS + , Graphics.Color.Illuminant.ITU.Rec470 + , Graphics.Color.Illuminant.ITU.Rec601 + , Graphics.Color.Model + , Graphics.Color.Space + -- , 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.AdobeRGB + , 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.ITU.Rec470 + , Graphics.Color.Space.RGB.ITU.Rec601 + , Graphics.Color.Space.RGB.ITU.Rec709 + , Graphics.Color.Space.RGB.Luma + -- , Graphics.Color.Space.RGB.SC + -- , Graphics.Color.Space.RGB.AdobeWideGamut + -- , Graphics.Color.Space.RGB.ProPhoto + -- , Graphics.Color.Space.RGB.DCI_P3 + + -- , Graphics.Color.Space.LMS + , Graphics.Color.Standard.RAL + , Graphics.Pixel + , Graphics.Pixel.ColorSpace + + other-modules: Graphics.Color.Adaptation.Internal + , Graphics.Color.Algebra.Elevator + , Graphics.Color.Model.CMYK + , Graphics.Color.Model.Internal + , Graphics.Color.Model.Alpha + , Graphics.Color.Model.RGB + , Graphics.Color.Model.HSI + , Graphics.Color.Model.HSL + , Graphics.Color.Model.HSV + , Graphics.Color.Model.Y + , Graphics.Color.Model.YCbCr + , Graphics.Color.Space.Internal + , Graphics.Color.Space.RGB.Internal + , Graphics.Pixel.Internal + build-depends: base >= 4.11 && < 5 + , deepseq + , data-default-class + , vector >= 0.10 + + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + other-modules: Graphics.Color.Model.Common + , Graphics.Color.Model.CMYKSpec + , Graphics.Color.Model.HSISpec + , Graphics.Color.Model.HSLSpec + , Graphics.Color.Model.HSVSpec + , Graphics.Color.Model.RGBSpec + , Graphics.Color.Space.Common + , Graphics.Color.Space.CIE1931.IlluminantSpec + , Graphics.Color.Space.CIE1976.LABSpec + , Graphics.Color.Space.RGB.SRGBSpec + , Graphics.Color.Space.RGB.Derived.SRGBSpec + , Graphics.Color.Space.RGB.ITU.Rec709Spec + , Graphics.Color.Space.YUV.YCbCrSpec + , Graphics.Color.Standard.RALSpec + , Spec + build-depends: HUnit + , QuickCheck + , base >= 4.8 && < 5 + , color + , colour + , hspec + , random + , vector + + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -fno-warn-orphans + -threaded + -freduction-depth=0 + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: doctests.hs + build-depends: base + , doctest >=0.15 + , QuickCheck + , color + , template-haskell + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -fno-warn-orphans + -threaded + + +benchmark conversion + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Conversion.hs + ghc-options: -Wall + -threaded + -O2 + build-depends: base + , criterion + , color + , colour + , deepseq + , random + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/lehins/color diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexey Kuleshevich (c) 2019-2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexey Kuleshevich nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,58 @@ +# 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) + +| 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. Currently supported: + +* Color models: + + * `Y` + * `RGB` + * `HSI` + * `HSL` + * `HSV` + * `YCbCr` + * `CMYK` + +* Color spaces and arbitrary conversions between them: + + * `Y` - luminance + * `XYZ` + * `La*b*` + * `RGB`: + + * `sRGB` + * `AdobeRGB` + * ITU: `Rec470`, `Rec601` and `Rec709` + * Alternative representations: + + * `HSI` + * `HSL` + * `HSV` + * `YCbCr` + * `CMYK` + +* Illuminants: + + * CIE1931 - 2 degree observer + * CIE1964 - 10 degree observer + * Some common alternatives + +* Chromatic adptation: + + * VonKries adptation with transformations: + + * VonKries + * Bradford (default) + * Fairchild + * CIECAM02 + +* Color Standards: + + * RAL diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,34 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/bench/Conversion.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Criterion.Main +import Control.DeepSeq +import System.Random as R +import qualified Graphics.Color.Model as CM +import Graphics.Color.Model +import Graphics.Color.Space +import Graphics.Color.Space.RGB +import Graphics.Color.Illuminant.CIE1931 +import Graphics.Color.Space.CIE1976.LAB +import qualified Graphics.Color.Space.RGB.Derived.SRGB as Derived + +import qualified Data.Colour as Colour +import qualified Data.Colour.SRGB as Colour +import qualified Data.Colour.CIE as Colour + +main :: IO () +main = + defaultMain $ + map + fst + [ mkBenchmarks (0 :: Float) "Float" gen + , mkBenchmarks (0 :: Double) "Double" gen + , mkBenchmarksLAB (0 :: Double) "L*a*b*" gen + ] + where + gen = mkStdGen 2019 + +randomV3 :: (RandomGen g, Random a, Elevator a) => g -> (V3 a, g) +randomV3 g0 = (V3 v0 v1 v2, g3) + where + (v0, g1) = randomR (minValue, maxValue) g0 + (v1, g2) = randomR (minValue, maxValue) g1 + (v2, g3) = randomR (minValue, maxValue) g2 + +makeRandomColor :: forall cs i a g . (ColorSpace cs i a, RandomGen g) => g -> (Color cs a, g) +makeRandomColor gen = + case randomV3 gen of + (V3 x y z, gen') -> (fromColorXYZ (ColorXYZ x y z :: Color (XYZ i) Double), gen') + + +makeRandomRGB :: + (RedGreenBlue cs (i :: k), RandomGen g, Random a, Elevator a) => g -> (Color cs a, g) +makeRandomRGB gen = + case randomV3 gen of + (V3 r g b, gen') -> (mkColorRGB (CM.ColorRGB r g b), gen') + +makeRandomColour :: + (RandomGen b1, Random b2, Elevator b2, Ord b2, Floating b2) => b1 -> (Colour.Colour b2, b1) +makeRandomColour gen = + case randomV3 gen of + (V3 r g b, gen') -> (Colour.sRGB r g b, gen') + + +sameAs :: a -> (b -> a) -> b -> a +sameAs _ = ($) + +mkBenchmarks :: + forall f g. (RandomGen g, Random f, Elevator f, RealFloat f, NFData f) + => f + -> String + -> g + -> (Benchmark, g) +mkBenchmarks _ tyName g0 = + let !(srgb :: Color SRGB f, g1) = makeRandomRGB g0 + !(srgbDerived :: Color (Derived.SRGB 'D65) 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 + xyzColour@(!_, !_, !_) = Colour.cieXYZView srgbColour + in ( bgroup + ("sRGB " <> tyName) + [ bgroup + "Standard" + [ bench "toColorXYZ" $ nf (sameAs xyz toColorXYZ) srgb + , bench "fromColorXYZ" $ nf (sameAs srgb fromColorXYZ) xyz + ] + , bgroup + "Derived" + [ bench "toColorXYZ" $ nf (sameAs xyzDerived toColorXYZ) srgbDerived + , bench "fromColorXYZ" $ nf (sameAs srgbDerived fromColorXYZ) xyzDerived + ] + , bgroup + "Colour" + [ bench "cieXYZView" $ nf Colour.cieXYZView srgbColour + , bench "cieXYZ" $ whnf (\(x, y, z) -> Colour.cieXYZ x y z) xyzColour + ] + ] + , g3) + + +mkBenchmarksLAB :: + forall f g. (RandomGen g, Elevator f, RealFloat f, NFData f) + => f + -> String + -> g + -> (Benchmark, g) +mkBenchmarksLAB _ tyName g0 = + let !(lab :: Color (LAB 'D65) f, g1) = makeRandomColor g0 + !(xyz :: Color (XYZ 'D65) f) = toColorXYZ lab + in ( bgroup + ("LAB " <> tyName) + [ bgroup + "Standard" + [ bench "toColorXYZ" $ nf (sameAs xyz toColorXYZ) lab + , bench "fromColorXYZ" $ nf (sameAs lab fromColorXYZ) xyz + ] + ] + , g1) diff --git a/src/Graphics/Color/Adaptation.hs b/src/Graphics/Color/Adaptation.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Adaptation.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Adaptation +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Adaptation + ( module Graphics.Color.Adaptation.Internal + , module Graphics.Color.Adaptation.VonKries + ) where + +import Graphics.Color.Adaptation.Internal +import Graphics.Color.Adaptation.VonKries diff --git a/src/Graphics/Color/Adaptation/Internal.hs b/src/Graphics/Color/Adaptation/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Adaptation/Internal.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Adaptation.Internal +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Adaptation.Internal + ( ChromaticAdaptation(..) + , Adaptation(..) + , chromaticAdaptation + , convertWith + , convertElevatedWith + , convertNoAdaptation + ) where + +import Graphics.Color.Space.Internal +import Graphics.Color.Space.RGB.Internal +import Data.Kind + + +class (Illuminant it, Illuminant ir, Elevator e, RealFloat e) => + ChromaticAdaptation (t :: k) (it :: kt) (ir :: kr) e + where + data Adaptation t it ir e :: Type + adaptColorXYZ :: Adaptation t it ir e -> Color (XYZ it) e -> Color (XYZ ir) e + +-- | This performs no adaptation, but only when illuminants are exactly the same +data ExactNoAdaptation + +instance (Illuminant i, Elevator e, RealFloat e) => + ChromaticAdaptation ExactNoAdaptation i i e where + data Adaptation ExactNoAdaptation i i e = ExactNoAdaptation + adaptColorXYZ _ = id + +-- | This performs no adaptation, but only when illuminants are almost the same. +data ApproximateNoAdaptation + +instance (Illuminant it, Illuminant ir, Elevator e, RealFloat e, Temperature it ~ Temperature ir) => + ChromaticAdaptation ApproximateNoAdaptation it ir e where + data Adaptation ApproximateNoAdaptation it ir e = ApproximateNoAdaptation + adaptColorXYZ _ (ColorXYZ x y z) = ColorXYZ x y z + +chromaticAdaptation :: + ChromaticAdaptation t it ir e + => Adaptation t it ir e + -> Gamut cst it e + -> Gamut csr ir e +chromaticAdaptation adaptation g = Gamut redPrimary greenPrimary bluePrimary + where + applyMatrix primary = + PrimaryChromaticity + (Chromaticity (fromColorXYZ (convertWith adaptation (primaryTristimulus primary)))) + redPrimary = applyMatrix (gamutRedPrimary g) + greenPrimary = applyMatrix (gamutGreenPrimary g) + bluePrimary = applyMatrix (gamutBluePrimary g) + + +convertWith :: + (ChromaticAdaptation t i' i e, ColorSpace cs' i' e, ColorSpace cs i e) + => Adaptation t i' i e + -> Color cs' e + -> Color cs e +convertWith = convertElevatedWith +{-# INLINE convertWith #-} + +convertElevatedWith :: + (ChromaticAdaptation t i' i a, ColorSpace cs' i' e', ColorSpace cs i e) + => Adaptation t i' i a + -> Color cs' e' + -> Color cs e +convertElevatedWith adaptation = fromColorXYZ . adaptColorXYZ adaptation . toColorXYZ +{-# INLINE[2] convertElevatedWith #-} + +-- | Convert a color from one color space into another one with the same illuminant, thus +-- not requiring a chromatic adaptation. +-- +-- @since 0.1.0 +convertNoAdaptation :: + forall cs' e' cs e i. (ColorSpace cs' i e', ColorSpace cs i e) + => Color cs' e' + -> Color cs e +convertNoAdaptation = fromColorXYZ . (toColorXYZ :: Color cs' e' -> Color (XYZ i) Double) +{-# INLINE convertNoAdaptation #-} + +convertNoAdaptationFloat :: + forall cs' e' cs e i. (ColorSpace cs' i e', ColorSpace cs i e) + => Color cs' e' + -> Color cs e +convertNoAdaptationFloat = fromColorXYZ . (toColorXYZ :: Color cs' e' -> Color (XYZ i) Float) +{-# INLINE convertNoAdaptationFloat #-} + +{-# RULES +"convertElevatedWith (Float)"[~2] forall (a :: Adaptation t i i Float) . convertElevatedWith a = convertNoAdaptationFloat +"convertElevatedWith (Double)"[~2] forall (a :: Adaptation t i i Double) . convertElevatedWith a = convertNoAdaptation +#-} + + +-- toword8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptationMatrix :: VonKriesAdaptationMatrix Bradford D50a D65 Double) (toColorXYZ (ColorLAB 76.022 (-0.366) 27.636 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double) diff --git a/src/Graphics/Color/Adaptation/VonKries.hs b/src/Graphics/Color/Adaptation/VonKries.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Adaptation/VonKries.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +-- | +-- Module : Graphics.Color.Adaptation.VonKries +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Adaptation.VonKries + ( VonKries(..) + , convert + , CAT(..) + , ICAT(..) + , ChromaticAdaptationTransform + , cat + , icat + , vonKriesAdaptation + , bradfordAdaptation + , fairchildAdaptation + , ciecam02Adaptation + , adaptationMatrix + ) where + +import Data.Coerce +import Data.Proxy +import Graphics.Color.Adaptation.Internal +import Graphics.Color.Algebra +import Graphics.Color.Space.Internal +--import Graphics.Color.Illuminant.CIE1931 +--import Graphics.Color.Space.RGB.SRGB +import Data.Typeable + +data VonKries + = VonKries + -- ^ VonKries chromatic adaptation transform matrix + -- + -- >>> 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 ] ] + -- >>> 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 ] ] + | Bradford + -- ^ Bradford chromatic adaptation transform matrix + -- + -- >>> 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 ] ] + -- >>> 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 ] ] + | Fairchild + -- ^ Fairchild chromatic adaptation transform matrix + -- + -- >>> 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 ] ] + -- >>> 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 ] ] + | CIECAM02 + -- ^ CIECAM02 chromatic adaptation transform matrix + -- + -- >>> cat :: CAT 'CIECAM02 Float + -- CAT VonKries 'CIECAM02 Float + -- [ [ 0.732800, 0.429600,-0.162400 ] + -- , [-0.703600, 1.697500, 0.006100 ] + -- , [ 0.003000, 0.013600, 0.983400 ] ] + -- >>> icat :: ICAT 'CIECAM02 Float + -- ICAT VonKries 'CIECAM02 Float + -- [ [ 1.096124,-0.278869, 0.182745 ] + -- , [ 0.454369, 0.473533, 0.072098 ] + -- , [-0.009628,-0.005698, 1.015326 ] ] + +-- | Chromatic adaptation transformation matrix matrix +newtype CAT (t :: k) e = + CAT (M3x3 e) + deriving (Eq) + +instance (Typeable t, Typeable k, Elevator e) => Show (CAT (t :: k) e) where + show m@(CAT m3x3) = asProxy m showsType "\n" ++ show m3x3 + +-- | Inverse of chromatic adaptation transformation matrix +newtype ICAT (t :: k) e = + ICAT (M3x3 e) + deriving (Eq) + +instance (Typeable t, Typeable k, Elevator e) => Show (ICAT (t :: k) e) where + show m@(ICAT m3x3) = asProxy m showsType "\n" ++ show m3x3 + +icat :: forall t e . (ChromaticAdaptationTransform t, RealFloat e) => ICAT t e +icat = ICAT (invertM3x3 m3x3) + where CAT m3x3 = cat :: CAT t e + +class ChromaticAdaptationTransform (t :: VonKries) where + cat :: RealFloat e => CAT t e + +instance ChromaticAdaptationTransform 'VonKries where + cat = CAT (M3x3 (V3 0.40024 0.70760 -0.08081) + (V3 -0.22630 1.16532 0.04570) + (V3 0.00000 0.00000 0.91822)) + +instance ChromaticAdaptationTransform 'Bradford where + cat = CAT (M3x3 (V3 0.8951 0.2664 -0.1614) + (V3 -0.7502 1.7135 0.0367) + (V3 0.0389 -0.0685 1.0296)) + +instance ChromaticAdaptationTransform 'Fairchild where + cat = CAT (M3x3 (V3 0.8562 0.3372 -0.1934) + (V3 -0.8360 1.8327 0.0033) + (V3 0.0357 -0.0469 1.0112)) + + +instance ChromaticAdaptationTransform 'CIECAM02 where + cat = CAT (M3x3 (V3 0.7328 0.4296 -0.1624) + (V3 -0.7036 1.6975 0.0061) + (V3 0.0030 0.0136 0.9834)) + +instance (Illuminant it, Illuminant ir, Elevator e, RealFloat e) => + ChromaticAdaptation (t :: VonKries) (it :: kt) (ir :: kr) e where + newtype Adaptation (t :: VonKries) (it :: kt) (ir :: kr) e = + AdaptationMatrix (M3x3 e) deriving (Eq) + adaptColorXYZ (AdaptationMatrix m3x3) px = coerce (multM3x3byV3 m3x3 (coerce px)) + {-# INLINE adaptColorXYZ #-} + +-- | Helper show type for the poly kinded illuminant +data I (i :: k) = I deriving Show + +instance (Illuminant it, Illuminant ir, Elevator e) => + Show (Adaptation (t :: VonKries) (it :: kt) (ir :: kr) e) where + showsPrec _ (AdaptationMatrix m3x3) = + ("AdaptationMatrix (" ++) . + showsType (Proxy :: Proxy (I (it :: kt))) . + (") (" ++) . showsType (Proxy :: Proxy (I (ir :: kr))) . (")\n" ++) . shows m3x3 + +adaptationMatrix :: + forall t it ir e. (ChromaticAdaptationTransform t, ChromaticAdaptation t it ir e) + => Adaptation (t :: VonKries) it ir e +adaptationMatrix = + AdaptationMatrix (multM3x3byM3x3 (multM3x3byV3d im3x3 diag) m3x3) + where + diag = multM3x3byV3 m3x3 wpRef / multM3x3byV3 m3x3 wpTest + CAT m3x3 = cat :: CAT t e + ICAT im3x3 = icat :: ICAT t e + wpTest = coerce (whitePointTristimulus :: Color (XYZ it) e) + wpRef = coerce (whitePointTristimulus :: Color (XYZ ir) e) +{-# NOINLINE adaptationMatrix #-} + +vonKriesAdaptation :: ChromaticAdaptation 'VonKries it ir e => Adaptation 'VonKries it ir e +vonKriesAdaptation = adaptationMatrix +{-# INLINE vonKriesAdaptation #-} + +fairchildAdaptation :: ChromaticAdaptation 'Fairchild it ir e => Adaptation 'Fairchild it ir e +fairchildAdaptation = adaptationMatrix +{-# INLINE fairchildAdaptation #-} + +bradfordAdaptation :: ChromaticAdaptation 'Bradford it ir e => Adaptation 'Bradford it ir e +bradfordAdaptation = adaptationMatrix +{-# INLINE bradfordAdaptation #-} + +ciecam02Adaptation :: ChromaticAdaptation 'CIECAM02 it ir e => Adaptation 'CIECAM02 it ir e +ciecam02Adaptation = adaptationMatrix +{-# INLINE ciecam02Adaptation #-} + +-- | 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 +-- more general functions `Graphics.Color.Adaptation.convertWith` or +-- `Graphics.Color.Adaptation.convertElevatedWith` can be used for selecting another +-- chromatic adaptation algorithm. +-- +-- @since 0.1.0 +convert :: (ColorSpace cs' i' e', ColorSpace cs i e) => Color cs' e' -> Color cs e +convert = convertElevatedWith (adaptationMatrix @'Bradford @_ @_ @Double) +{-# INLINE convert #-} + + +-- RAL adopted: Daffodil yellow +-- toWord8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptation :: VonKriesAdaptation Bradford D50a D65 Float) (toColorXYZ (ColorLAB 66.5 27.308 80.402 :: Color (LAB D50a) Float) :: Color XYZ Float)) :: Color SRGB Float) +-- + + +-- +-- toWord8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptation :: VonKriesAdaptation Bradford D50a D65 Double) (toColorXYZ (ColorLAB 83.353 3.462 75.829 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double) +-- + + +-- -- Green beige +-- toWord8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptation :: VonKriesAdaptation Bradford D50a D65 Double) (toColorXYZ (ColorLAB 76.022 (-0.366) 27.636 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double) +-- + +-- From srgb spec +-- srgbVonKries :: VonKriesAdaptationMatrix t it ir Double +-- srgbVonKries = VonKriesAdaptationMatrix $ M3x3 +-- (V3 1.047844353856414 0.022898981050086 -0.050206647741605) +-- (V3 0.029549007606644 0.990508028941971 -0.017074711360960) +-- (V3 -0.009250984365223 0.015072338237051 0.751717835079977) diff --git a/src/Graphics/Color/Algebra.hs b/src/Graphics/Color/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Algebra.hs @@ -0,0 +1,476 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Graphics.Color.Algebra +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Algebra + ( -- * 2D + V2(..) + -- * 3D + , V3(..) + , showV3 + , dotProduct + , M3x3(..) + , showM3x3 + , detM3x3 + , invertM3x3 + , multM3x3byV3 + , multM3x3byM3x3 + , multM3x3byV3d + , transposeM3x3 + , module Graphics.Color.Algebra.Elevator + -- * Helpers + , showsType + , asProxy + ) where + +import Data.Typeable +import Foreign.Ptr +import Control.Applicative +import Foreign.Storable +import Graphics.Color.Algebra.Elevator + + +-------- +-- V2 -- +-------- + +-- | A 2D vector with @x@ and @y@ coordinates. +data V2 a = V2 !a !a + deriving (Eq, Ord) + +instance Elevator a => Show (V2 a) where + showsPrec _ (V2 x y) = + ('[' :) . toShowS x . (',' :) . toShowS y . (" ]" ++) + +instance Functor V2 where + fmap f (V2 x y) = V2 (f x) (f y) + {-# INLINE fmap #-} + + +zipWithV2 :: (a -> b -> c) -> V2 a -> V2 b -> V2 c +zipWithV2 f (V2 x1 y1) (V2 x2 y2) = V2 (f x1 x2) (f y1 y2) +{-# INLINE zipWithV2 #-} + +instance Applicative V2 where + pure x = V2 x x + {-# INLINE pure #-} + (<*>) (V2 fx1 fy1) (V2 x2 y2) = V2 (fx1 x2) (fy1 y2) + {-# INLINE (<*>) #-} +#if MIN_VERSION_base(4,10,0) + liftA2 = zipWithV2 + {-# INLINE liftA2 #-} +#endif + +instance Foldable V2 where + foldr f acc (V2 x y) = f x (f y acc) + {-# INLINE foldr #-} + +instance Traversable V2 where + traverse f (V2 x y) = V2 <$> f x <*> f y + {-# INLINE traverse #-} + +instance Num a => Num (V2 a) where + (+) = zipWithV2 (+) + {-# INLINE (+) #-} + (-) = zipWithV2 (-) + {-# INLINE (-) #-} + (*) = zipWithV2 (*) + {-# INLINE (*) #-} + abs = fmap abs + {-# INLINE abs #-} + signum = fmap signum + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + + +instance Fractional a => Fractional (V2 a) where + (/) = zipWithV2 (/) + {-# INLINE (/) #-} + recip = fmap recip + {-# INLINE recip #-} + fromRational = pure . fromRational + {-# INLINE fromRational #-} + + +instance Floating a => Floating (V2 a) where + pi = pure pi + {-# INLINE pi #-} + exp = fmap exp + {-# INLINE exp #-} + log = fmap log + {-# INLINE log #-} + sin = fmap sin + {-# INLINE sin #-} + cos = fmap cos + {-# INLINE cos #-} + asin = fmap asin + {-# INLINE asin #-} + atan = fmap atan + {-# INLINE atan #-} + acos = fmap acos + {-# INLINE acos #-} + sinh = fmap sinh + {-# INLINE sinh #-} + cosh = fmap cosh + {-# INLINE cosh #-} + asinh = fmap asinh + {-# INLINE asinh #-} + atanh = fmap atanh + {-# INLINE atanh #-} + acosh = fmap acosh + {-# INLINE acosh #-} + + +instance Storable e => Storable (V2 e) where + sizeOf _ = 2 * sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek p = + let q = castPtr p + in V2 <$> peek q <*> peekElemOff q 1 + {-# INLINE peek #-} + poke p (V2 v0 v1) = + let q = castPtr p + in poke q v0 >> pokeElemOff q 1 v1 + {-# INLINE poke #-} + + +-------- +-- V3 -- +-------- + +-- | A 3D vector with @x@, @y@ and @z@ coordinates. +data V3 a = V3 !a !a !a + deriving (Eq, Ord) + +instance Elevator a => Show (V3 a) where + showsPrec _ (V3 x y z) = + ('[' :) . toShowS x . (',' :) . toShowS y . (',' :) . toShowS z . (" ]" ++) + +showV3 :: Show a => V3 a -> String +showV3 (V3 x y z) = concat ["[ ", show x, ", ", show y, ", ", show z, " ]"] + +-- | Mulitply a 1x3 vector by a 3x1 vector, i.e. dot product. +-- +-- @since 0.1.0 +dotProduct :: Num a => V3 a -> V3 a -> a +dotProduct (V3 u0 u1 u2) (V3 v0 v1 v2) = u0 * v0 + u1 * v1 + u2 * v2 +{-# INLINE dotProduct #-} + + +zipWithV3 :: (a -> b -> c) -> V3 a -> V3 b -> V3 c +zipWithV3 f (V3 x1 y1 z1) (V3 x2 y2 z2) = V3 (f x1 x2) (f y1 y2) (f z1 z2) +{-# INLINE zipWithV3 #-} + +instance Functor V3 where + fmap f (V3 x y z) = V3 (f x) (f y) (f z) + {-# INLINE fmap #-} + +instance Applicative V3 where + pure x = V3 x x x + {-# INLINE pure #-} + (<*>) (V3 fx1 fy1 fz1) (V3 x2 y2 z2) = V3 (fx1 x2) (fy1 y2) (fz1 z2) + {-# INLINE (<*>) #-} +#if MIN_VERSION_base(4,10,0) + liftA2 = zipWithV3 + {-# INLINE liftA2 #-} +#endif + +instance Foldable V3 where + foldr f acc (V3 x y z) = f x (f y (f z acc)) + {-# INLINE foldr #-} + +instance Traversable V3 where + traverse f (V3 x y z) = V3 <$> f x <*> f y <*> f z + {-# INLINE traverse #-} + +instance Num a => Num (V3 a) where + (+) = zipWithV3 (+) + {-# INLINE (+) #-} + (-) = zipWithV3 (-) + {-# INLINE (-) #-} + (*) = zipWithV3 (*) + {-# INLINE (*) #-} + abs = fmap abs + {-# INLINE abs #-} + signum = fmap signum + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + + +instance Fractional a => Fractional (V3 a) where + (/) = zipWithV3 (/) + {-# INLINE (/) #-} + recip = fmap recip + {-# INLINE recip #-} + fromRational = pure . fromRational + {-# INLINE fromRational #-} + + +instance Floating a => Floating (V3 a) where + pi = pure pi + {-# INLINE pi #-} + exp = fmap exp + {-# INLINE exp #-} + log = fmap log + {-# INLINE log #-} + sin = fmap sin + {-# INLINE sin #-} + cos = fmap cos + {-# INLINE cos #-} + asin = fmap asin + {-# INLINE asin #-} + atan = fmap atan + {-# INLINE atan #-} + acos = fmap acos + {-# INLINE acos #-} + sinh = fmap sinh + {-# INLINE sinh #-} + cosh = fmap cosh + {-# INLINE cosh #-} + asinh = fmap asinh + {-# INLINE asinh #-} + atanh = fmap atanh + {-# INLINE atanh #-} + acosh = fmap acosh + {-# INLINE acosh #-} + + +instance Storable e => Storable (V3 e) where + sizeOf _ = 3 * sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek p = do + let q = castPtr p + v0 <- peek q + v1 <- peekElemOff q 1 + v2 <- peekElemOff q 2 + return $! V3 v0 v1 v2 + + {-# INLINE peek #-} + poke p (V3 v0 v1 v2) = do + let q = castPtr p + poke q v0 + pokeElemOff q 1 v1 + pokeElemOff q 2 v2 + {-# INLINE poke #-} + +---------- +-- M3x3 -- +---------- + + + +-- | A 3x3 Matrix +data M3x3 a = M3x3 + { m3x3row0 :: {-# UNPACK #-}!(V3 a) + , m3x3row1 :: {-# UNPACK #-}!(V3 a) + , m3x3row2 :: {-# UNPACK #-}!(V3 a) + } deriving (Eq) + +instance Elevator a => Show (M3x3 a) where + showsPrec _ (M3x3 v0 v1 v2) = + ("[ " ++) . shows v0 . ("\n, " ++) . shows v1 . ("\n, " ++) . shows v2 . (" ]" ++) + + +showM3x3 :: Show a => M3x3 a -> String +showM3x3 (M3x3 v0 v1 v2) = + concat ["[ ", showV3 v0, "\n, ", showV3 v1, "\n, ", showV3 v2, " ]"] + + +-- | Mulitply a 3x3 matrix by a 3x1 vector, while getting a vector back. +-- +-- @since 0.1.0 +multM3x3byV3 :: Num a => M3x3 a -> V3 a -> V3 a +multM3x3byV3 (M3x3 (V3 a b c) + (V3 d e f) + (V3 g h i)) (V3 v0 v1 v2) = V3 (a * v0 + b * v1 + c * v2) + (d * v0 + e * v1 + f * v2) + (g * v0 + h * v1 + i * v2) +{-# INLINE multM3x3byV3 #-} + + +multM3x3byM3x3 :: Num a => M3x3 a -> M3x3 a -> M3x3 a +multM3x3byM3x3 m1 m2 = + M3x3 + (V3 (a1 * a2 + b1 * d2 + c1 * g2) (a1 * b2 + b1 * e2 + c1 * h2) (a1 * c2 + b1 * f2 + c1 * i2)) + (V3 (d1 * a2 + e1 * d2 + f1 * g2) (d1 * b2 + e1 * e2 + f1 * h2) (d1 * c2 + e1 * f2 + f1 * i2)) + (V3 (g1 * a2 + h1 * d2 + i1 * g2) (g1 * b2 + h1 * e2 + i1 * h2) (g1 * c2 + h1 * f2 + i1 * i2)) + where + M3x3 (V3 a1 b1 c1) + (V3 d1 e1 f1) + (V3 g1 h1 i1) = m1 + M3x3 (V3 a2 b2 c2) + (V3 d2 e2 f2) + (V3 g2 h2 i2) = m2 +{-# INLINE multM3x3byM3x3 #-} + +-- | Multiply a 3x3 matrix by another 3x3 diagonal matrix represented by a 1x3 vector +multM3x3byV3d :: Num a => M3x3 a -> V3 a -> M3x3 a +multM3x3byV3d m1 m2 = + M3x3 + (V3 (a1 * a2) (b1 * e2) (c1 * i2)) + (V3 (d1 * a2) (e1 * e2) (f1 * i2)) + (V3 (g1 * a2) (h1 * e2) (i1 * i2)) + where + M3x3 (V3 a1 b1 c1) + (V3 d1 e1 f1) + (V3 g1 h1 i1) = m1 + V3 a2 e2 i2 = m2 +{-# INLINE multM3x3byV3d #-} + + +-- | Invert a 3x3 matrix. +-- +-- @since 0.1.0 +invertM3x3 :: Fractional a => M3x3 a -> M3x3 a +invertM3x3 (M3x3 (V3 a b c) + (V3 d e f) + (V3 g h i)) = + M3x3 (V3 (a' / det) (d' / det) (g' / det)) + (V3 (b' / det) (e' / det) (h' / det)) + (V3 (c' / det) (f' / det) (i' / det)) + where + !a' = e*i - f*h + !b' = -(d*i - f*g) + !c' = d*h - e*g + !d' = -(b*i - c*h) + !e' = a*i - c*g + !f' = -(a*h - b*g) + !g' = b*f - c*e + !h' = -(a*f - c*d) + !i' = a*e - b*d + !det = a*a' + b*b' + c*c' +{-# INLINE invertM3x3 #-} + + +-- | Compute a determinant of a 3x3 matrix. +-- +-- @since 0.1.0 +detM3x3 :: Num a => M3x3 a -> a +detM3x3 (M3x3 (V3 i00 i01 i02) + (V3 i10 i11 i12) + (V3 i20 i21 i22)) = i00 * (i11 * i22 - i12 * i21) + + i01 * (i12 * i20 - i10 * i22) + + i02 * (i10 * i21 - i11 * i20) +{-# INLINE detM3x3 #-} + + +transposeM3x3 :: M3x3 a -> M3x3 a +transposeM3x3 (M3x3 (V3 i00 i01 i02) + (V3 i10 i11 i12) + (V3 i20 i21 i22)) = M3x3 (V3 i00 i10 i20) + (V3 i01 i11 i21) + (V3 i02 i12 i22) +{-# INLINE transposeM3x3 #-} + + + +pureM3x3 :: a -> M3x3 a +pureM3x3 x = M3x3 (pure x) (pure x) (pure x) +{-# INLINE pureM3x3 #-} + +mapM3x3 :: (a -> a) -> M3x3 a -> M3x3 a +mapM3x3 f (M3x3 v0 v1 v2) = M3x3 (fmap f v0) (fmap f v1) (fmap f v2) +{-# INLINE mapM3x3 #-} + +zipWithM3x3 :: (a -> b -> c) -> M3x3 a -> M3x3 b -> M3x3 c +zipWithM3x3 f (M3x3 v10 v11 v12) (M3x3 v20 v21 v22) = + M3x3 (zipWithV3 f v10 v20) (zipWithV3 f v11 v21) (zipWithV3 f v12 v22) +{-# INLINE zipWithM3x3 #-} + + +instance Functor M3x3 where + fmap f (M3x3 v0 v1 v2) = M3x3 (fmap f v0) (fmap f v1) (fmap f v2) + {-# INLINE fmap #-} + +instance Applicative M3x3 where + pure x = M3x3 (pure x) (pure x) (pure x) + {-# INLINE pure #-} + (<*>) (M3x3 fx1 fy1 fz1) (M3x3 x2 y2 z2) = M3x3 (fx1 <*> x2) (fy1 <*> y2) (fz1 <*> z2) + {-# INLINE (<*>) #-} +#if MIN_VERSION_base(4,10,0) + liftA2 = zipWithM3x3 + {-# INLINE liftA2 #-} +#endif + +instance Foldable M3x3 where + foldr f acc (M3x3 x y z) = foldr f (foldr f (foldr f acc z) y) x + {-# INLINE foldr #-} + +instance Traversable M3x3 where + traverse f (M3x3 x y z) = M3x3 <$> traverse f x <*> traverse f y <*> traverse f z + {-# INLINE traverse #-} + + +instance Num a => Num (M3x3 a) where + (+) = zipWithM3x3 (+) + {-# INLINE (+) #-} + (-) = zipWithM3x3 (-) + {-# INLINE (-) #-} + (*) = zipWithM3x3 (*) + {-# INLINE (*) #-} + abs = mapM3x3 abs + {-# INLINE abs #-} + signum = mapM3x3 signum + {-# INLINE signum #-} + fromInteger = pureM3x3 . fromInteger + {-# INLINE fromInteger #-} + + +instance Fractional a => Fractional (M3x3 a) where + (/) = zipWithM3x3 (/) + {-# INLINE (/) #-} + recip = mapM3x3 recip + {-# INLINE recip #-} + fromRational = pureM3x3 . fromRational + {-# INLINE fromRational #-} + + +instance Floating a => Floating (M3x3 a) where + pi = pureM3x3 pi + {-# INLINE pi #-} + exp = mapM3x3 exp + {-# INLINE exp #-} + log = mapM3x3 log + {-# INLINE log #-} + sin = mapM3x3 sin + {-# INLINE sin #-} + cos = mapM3x3 cos + {-# INLINE cos #-} + asin = mapM3x3 asin + {-# INLINE asin #-} + atan = mapM3x3 atan + {-# INLINE atan #-} + acos = mapM3x3 acos + {-# INLINE acos #-} + sinh = mapM3x3 sinh + {-# INLINE sinh #-} + cosh = mapM3x3 cosh + {-# INLINE cosh #-} + asinh = mapM3x3 asinh + {-# INLINE asinh #-} + atanh = mapM3x3 atanh + {-# INLINE atanh #-} + acosh = mapM3x3 acosh + {-# INLINE acosh #-} + + + +showsType :: Typeable t => proxy t -> ShowS +showsType = showsTypeRep . typeRep + +asProxy :: p -> (Proxy p -> t) -> t +asProxy _ f = f (Proxy :: Proxy a) diff --git a/src/Graphics/Color/Algebra/Binary.hs b/src/Graphics/Color/Algebra/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Algebra/Binary.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Algebra.Binary +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Algebra.Binary + ( Bit + , zero + , one + , toBool + , fromBool + , toNum + , fromNum + ) where + +import Control.Monad +import Data.Bits +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) + + +-- | Under the hood, binary pixels are backed by `Word8`, but can only take +-- values of @0@ or @1@. Use `zero`\/`one` to construct a bit and `on`\/`off` to +-- construct a binary pixel. +newtype Bit = Bit Word8 deriving (Ord, Eq, Storable) + + +instance Show Bit where + show (Bit 0) = "0" + show _ = "1" + + +instance Bits Bit where + (Bit 0) .&. _ = Bit 0 + (Bit 1) .&. (Bit 1) = Bit 1 + _ .&. (Bit 0) = Bit 0 + _ .&. _ = Bit 1 + {-# INLINE (.&.) #-} + (Bit 1) .|. _ = Bit 1 + (Bit 0) .|. (Bit 0) = Bit 0 + _ .|. _ = Bit 1 + {-# INLINE (.|.) #-} + (Bit 0) `xor` (Bit 0) = Bit 0 + (Bit 1) `xor` (Bit 1) = Bit 0 + _ `xor` _ = Bit 1 + {-# INLINE xor #-} + complement (Bit 0) = Bit 1 + complement _ = Bit 0 + {-# INLINE complement #-} + shift !b 0 = b + shift _ _ = Bit 0 + {-# INLINE shift #-} + rotate !b _ = b + {-# INLINE rotate #-} + zeroBits = Bit 0 + {-# INLINE zeroBits #-} + bit 0 = Bit 1 + bit _ = Bit 0 + {-# INLINE bit #-} + testBit (Bit 1) 0 = True + testBit _ _ = False + {-# INLINE testBit #-} + bitSizeMaybe _ = Just 1 + {-# INLINE bitSizeMaybe #-} + bitSize _ = 1 + {-# INLINE bitSize #-} + isSigned _ = False + {-# INLINE isSigned #-} + popCount (Bit 0) = 0 + popCount _ = 1 + {-# INLINE popCount #-} + + +-- | Convert `Bit` to `Bool` +-- +-- @since 0.1.0 +toBool :: Bit -> Bool +toBool (Bit 0) = False +toBool _ = True +{-# INLINE toBool #-} + +-- | Convert `Bool` to `Bit` +-- +-- @since 0.1.0 +fromBool :: Bool -> Bit +fromBool False = zero +fromBool True = one +{-# INLINE fromBool #-} + +-- | Convert a bit to a number. +-- +-- @since 0.1.0 +toNum :: Num a => Bit -> a +toNum (Bit 0) = 0 +toNum _ = 1 +{-# INLINE toNum #-} + +-- | Convert a number to a bit. Any non-zero number corresponds to @1@. +-- +-- @since 0.1.0 +fromNum :: (Eq a, Num a) => a -> Bit +fromNum 0 = zero +fromNum _ = one +{-# INLINE fromNum #-} + + +zero :: Bit +zero = Bit 0 +{-# INLINE zero #-} + +one :: Bit +one = Bit 1 +{-# INLINE one #-} + + +-- | Values: @0@ and @1@ +instance Elevator Bit where + minValue = Bit 0 + {-# INLINE minValue #-} + maxValue = Bit 1 + {-# INLINE maxValue #-} + toShowS (Bit 0) = ('0':) + toShowS _ = ('1':) + toWord8 (Bit 0) = 0 + toWord8 _ = maxBound + {-# INLINE toWord8 #-} + toWord16 (Bit 0) = 0 + toWord16 _ = maxBound + {-# INLINE toWord16 #-} + toWord32 (Bit 0) = 0 + toWord32 _ = maxBound + {-# INLINE toWord32 #-} + toWord64 (Bit 0) = 0 + toWord64 _ = maxBound + {-# INLINE toWord64 #-} + toFloat (Bit 0) = 0 + toFloat _ = 1 + {-# INLINE toFloat #-} + toRealFloat (Bit 0) = 0 + toRealFloat _ = 1 + {-# INLINE toRealFloat #-} + fromRealFloat 0 = Bit 0 + fromRealFloat _ = Bit 1 + {-# INLINE fromRealFloat #-} + + +instance Num Bit where + (+) = (.|.) + {-# INLINE (+) #-} + -- 0 - 0 = 0 + -- 0 - 1 = 0 + -- 1 - 0 = 1 + -- 1 - 1 = 0 + (Bit 0) - (Bit 0) = Bit 0 + _ - (Bit 0) = Bit 1 + _ - _ = Bit 0 + {-# INLINE (-) #-} + (*) = (.&.) + {-# INLINE (*) #-} + abs = id + {-# INLINE abs #-} + signum = id + {-# INLINE signum #-} + fromInteger 0 = Bit 0 + fromInteger _ = Bit 1 + {-# INLINE fromInteger #-} + +-- | Unboxing of a `Bit`. +instance U.Unbox Bit + +newtype instance U.MVector s Bit = MV_Bit (U.MVector s Word8) + +instance M.MVector U.MVector Bit where + basicLength (MV_Bit mvec) = M.basicLength mvec + {-# INLINE basicLength #-} + basicUnsafeSlice idx len (MV_Bit mvec) = MV_Bit (M.basicUnsafeSlice idx len mvec) + {-# INLINE basicUnsafeSlice #-} + basicOverlaps (MV_Bit mvec) (MV_Bit mvec') = M.basicOverlaps mvec mvec' + {-# INLINE basicOverlaps #-} + basicUnsafeNew len = MV_Bit `liftM` M.basicUnsafeNew len + {-# INLINE basicUnsafeNew #-} + basicUnsafeReplicate len (Bit w) = MV_Bit `liftM` M.basicUnsafeReplicate len w + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeRead (MV_Bit mvec) idx = Bit `liftM` M.basicUnsafeRead mvec idx + {-# INLINE basicUnsafeRead #-} + basicUnsafeWrite (MV_Bit mvec) idx (Bit w) = M.basicUnsafeWrite mvec idx w + {-# INLINE basicUnsafeWrite #-} + basicClear (MV_Bit mvec) = M.basicClear mvec + {-# INLINE basicClear #-} + basicSet (MV_Bit mvec) (Bit w) = M.basicSet mvec w + {-# INLINE basicSet #-} + basicUnsafeCopy (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeCopy mvec mvec' + {-# INLINE basicUnsafeCopy #-} + basicUnsafeMove (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeMove mvec mvec' + {-# INLINE basicUnsafeMove #-} + basicUnsafeGrow (MV_Bit mvec) len = MV_Bit `liftM` M.basicUnsafeGrow mvec len + {-# INLINE basicUnsafeGrow #-} +#if MIN_VERSION_vector(0,11,0) + basicInitialize (MV_Bit mvec) = M.basicInitialize mvec + {-# INLINE basicInitialize #-} +#endif + + +newtype instance U.Vector Bit = V_Bit (U.Vector Word8) + +instance V.Vector U.Vector Bit where + basicUnsafeFreeze (MV_Bit mvec) = V_Bit `liftM` V.basicUnsafeFreeze mvec + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeThaw (V_Bit vec) = MV_Bit `liftM` V.basicUnsafeThaw vec + {-# INLINE basicUnsafeThaw #-} + basicLength (V_Bit vec) = V.basicLength vec + {-# INLINE basicLength #-} + basicUnsafeSlice idx len (V_Bit vec) = V_Bit (V.basicUnsafeSlice idx len vec) + {-# INLINE basicUnsafeSlice #-} + basicUnsafeIndexM (V_Bit vec) idx = Bit `liftM` V.basicUnsafeIndexM vec idx + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeCopy (MV_Bit mvec) (V_Bit vec) = V.basicUnsafeCopy mvec vec + {-# INLINE basicUnsafeCopy #-} + elemseq (V_Bit vec) (Bit w) = V.elemseq vec w + {-# INLINE elemseq #-} diff --git a/src/Graphics/Color/Algebra/Elevator.hs b/src/Graphics/Color/Algebra/Elevator.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Algebra/Elevator.hs @@ -0,0 +1,425 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +#if __GLASGOW_HASKELL__ >= 800 + {-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif +-- | +-- Module : Graphics.Color.Algebra.Elevator +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Algebra.Elevator + ( Elevator(..) + , module Data.Word + , clamp01 + ) where + +import Data.Complex +import Data.Int +import Data.Typeable +import Data.Vector.Storable (Storable) +import Data.Vector.Unboxed (Unbox) +import Data.Word +import GHC.Float +import Text.Printf + +defFieldFormat :: FieldFormat +defFieldFormat = FieldFormat Nothing Nothing Nothing Nothing False "" 'v' + +-- | A class with a set of functions that allow for changing precision by shrinking and +-- streatching the values. +class (Show e, Eq e, Num e, Typeable e, Unbox e, Storable e) => Elevator e where + maxValue :: e + + minValue :: e + + fieldFormat :: e -> FieldFormat + fieldFormat _ = defFieldFormat + + -- | This is a pretty printer for the value. + toShowS :: e -> ShowS + default toShowS :: PrintfArg e => e -> ShowS + toShowS e = formatArg e (fieldFormat e) + + -- | Values are scaled to @[0, 255]@ range. + toWord8 :: e -> Word8 + + -- | Values are scaled to @[0, 65535]@ range. + toWord16 :: e -> Word16 + + -- | Values are scaled to @[0, 4294967295]@ range. + toWord32 :: e -> Word32 + + -- | Values are scaled to @[0, 18446744073709551615]@ range. + toWord64 :: e -> Word64 + + -- | Values are scaled to @[0.0, 1.0]@ range. + toRealFloat :: (Elevator a, RealFloat a) => e -> a + + -- | Values are scaled from @[0.0, 1.0]@ range. + fromRealFloat :: (Elevator a, RealFloat a) => a -> e + + -- | Values are scaled to @[0.0, 1.0]@ range. + toFloat :: e -> Float + toFloat = toRealFloat + + -- | Values are scaled to @[0.0, 1.0]@ range. + toDouble :: e -> Double + toDouble = toRealFloat + + -- | Values are scaled from @[0.0, 1.0]@ range. + fromDouble :: Double -> e + fromDouble = fromRealFloat + + +-- | 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` + fromIntegral (maxBound :: b)) +{-# INLINE dropDown #-} + +-- | Increase the precision +raiseUp :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b +raiseUp !e = fromIntegral e * ((maxBound :: b) `div` fromIntegral (maxBound :: a)) +{-# INLINE raiseUp #-} + +-- | Convert to fractional with value less than or equal to 1. +squashTo1 :: forall a b. (Fractional b, Integral a, Bounded a) => a -> b +squashTo1 !e = fromIntegral e / fromIntegral (maxBound :: a) +{-# INLINE squashTo1 #-} + +-- | Convert to integral streaching it's value up to a maximum value. +stretch :: forall a b. (RealFrac a, Floating a, Integral b, Bounded b) => a -> b +stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e) +{-# INLINE stretch #-} + + +-- | Clamp a value to @[0, 1]@ range. +clamp01 :: (Ord a, Floating a) => a -> a +clamp01 !x = min (max 0 x) 1 +{-# INLINE clamp01 #-} + + +-- | Values between @[0, 255]]@ +instance Elevator Word8 where + maxValue = maxBound + minValue = minBound + fieldFormat _ = defFieldFormat {fmtWidth = Just 3, fmtChar = 'd'} + toWord8 = id + {-# INLINE toWord8 #-} + toWord16 = raiseUp + {-# INLINE toWord16 #-} + toWord32 = raiseUp + {-# INLINE toWord32 #-} + toWord64 = raiseUp + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = toWord8 + {-# INLINE fromDouble #-} + toRealFloat = squashTo1 + {-# INLINE toRealFloat #-} + fromRealFloat = toWord8 + {-# INLINE fromRealFloat #-} + + +-- | Values between @[0, 65535]]@ +instance Elevator Word16 where + maxValue = maxBound + minValue = minBound + fieldFormat _ = defFieldFormat { fmtWidth = Just 5, fmtChar = 'd'} + toWord8 = dropDown + {-# INLINE toWord8 #-} + toWord16 = id + {-# INLINE toWord16 #-} + toWord32 = raiseUp + {-# INLINE toWord32 #-} + toWord64 = raiseUp + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = toWord16 + {-# INLINE fromDouble #-} + toRealFloat = squashTo1 + {-# INLINE toRealFloat #-} + fromRealFloat = toWord16 + {-# INLINE fromRealFloat #-} + + +-- | Values between @[0, 4294967295]@ +instance Elevator Word32 where + maxValue = maxBound + minValue = minBound + fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'} + toWord8 = dropDown + {-# INLINE toWord8 #-} + toWord16 = dropDown + {-# INLINE toWord16 #-} + toWord32 = id + {-# INLINE toWord32 #-} + toWord64 = raiseUp + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = toWord32 + {-# INLINE fromDouble #-} + toRealFloat = squashTo1 + {-# INLINE toRealFloat #-} + fromRealFloat = toWord32 + {-# INLINE fromRealFloat #-} + + +-- | Values between @[0, 18446744073709551615]@ +instance Elevator Word64 where + maxValue = maxBound + minValue = minBound + fieldFormat _ = defFieldFormat { fmtWidth = Just 20, fmtChar = 'd'} + toWord8 = dropDown + {-# INLINE toWord8 #-} + toWord16 = dropDown + {-# INLINE toWord16 #-} + toWord32 = dropDown + {-# INLINE toWord32 #-} + toWord64 = id + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = toWord64 + {-# INLINE fromDouble #-} + toRealFloat = squashTo1 + {-# INLINE toRealFloat #-} + fromRealFloat = toWord64 + {-# INLINE fromRealFloat #-} + +-- | Values between @[0, 18446744073709551615]@ on 64bit +instance Elevator Word where + maxValue = maxBound + minValue = minBound +#if WORD_SIZE_IN_BITS < 64 + fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'} +#else + fieldFormat _ = defFieldFormat { fmtWidth = Just 20, fmtChar = 'd'} +#endif + toWord8 = dropDown + {-# INLINE toWord8 #-} + toWord16 = dropDown + {-# INLINE toWord16 #-} + toWord32 = dropDown + {-# INLINE toWord32 #-} + toWord64 = fromIntegral + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = stretch . clamp01 + {-# INLINE fromDouble #-} + toRealFloat = squashTo1 + {-# INLINE toRealFloat #-} + fromRealFloat = stretch . clamp01 + {-# INLINE fromRealFloat #-} + +-- | Values between @[0, 127]@ +instance Elevator Int8 where + maxValue = maxBound + minValue = 0 + fieldFormat _ = defFieldFormat { fmtWidth = Just 3, fmtChar = 'd'} + toWord8 = fromIntegral . max 0 + {-# INLINE toWord8 #-} + toWord16 = raiseUp . max 0 + {-# INLINE toWord16 #-} + toWord32 = raiseUp . max 0 + {-# INLINE toWord32 #-} + toWord64 = raiseUp . max 0 + {-# INLINE toWord64 #-} + toFloat = squashTo1 . max 0 + {-# INLINE toFloat #-} + toRealFloat = squashTo1 . max 0 + {-# INLINE toRealFloat #-} + fromRealFloat = stretch . clamp01 + {-# INLINE fromRealFloat #-} + + +-- | Values between @[0, 32767]@ +instance Elevator Int16 where + maxValue = maxBound + minValue = 0 + fieldFormat _ = defFieldFormat { fmtWidth = Just 5, fmtChar = 'd'} + toWord8 = dropDown . max 0 + {-# INLINE toWord8 #-} + toWord16 = fromIntegral . max 0 + {-# INLINE toWord16 #-} + toWord32 = raiseUp . max 0 + {-# INLINE toWord32 #-} + toWord64 = raiseUp . max 0 + {-# INLINE toWord64 #-} + toFloat = squashTo1 . max 0 + {-# INLINE toFloat #-} + toRealFloat = squashTo1 . max 0 + {-# INLINE toRealFloat #-} + fromRealFloat = stretch . clamp01 + {-# INLINE fromRealFloat #-} + + +-- | Values between @[0, 2147483647]@ +instance Elevator Int32 where + maxValue = maxBound + minValue = 0 + fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'} + toWord8 = dropDown . max 0 + {-# INLINE toWord8 #-} + toWord16 = dropDown . max 0 + {-# INLINE toWord16 #-} + toWord32 = fromIntegral . max 0 + {-# INLINE toWord32 #-} + toWord64 = raiseUp . max 0 + {-# INLINE toWord64 #-} + toFloat = squashTo1 . max 0 + {-# INLINE toFloat #-} + toRealFloat = squashTo1 . max 0 + {-# INLINE toRealFloat #-} + fromRealFloat = stretch . clamp01 + {-# INLINE fromRealFloat #-} + + +-- | Values between @[0, 9223372036854775807]@ +instance Elevator Int64 where + maxValue = maxBound + minValue = 0 + fieldFormat _ = defFieldFormat { fmtWidth = Just 19, fmtChar = 'd'} + toWord8 = dropDown . max 0 + {-# INLINE toWord8 #-} + toWord16 = dropDown . max 0 + {-# INLINE toWord16 #-} + toWord32 = dropDown . max 0 + {-# INLINE toWord32 #-} + toWord64 = fromIntegral . max 0 + {-# INLINE toWord64 #-} + toFloat = squashTo1 . max 0 + {-# INLINE toFloat #-} + toRealFloat = squashTo1 . max 0 + {-# INLINE toRealFloat #-} + fromRealFloat = stretch . clamp01 + {-# INLINE fromRealFloat #-} + + +-- | Values between @[0, 9223372036854775807]@ on 64bit +instance Elevator Int where + maxValue = maxBound + minValue = 0 +#if WORD_SIZE_IN_BITS < 64 + fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'} +#else + fieldFormat _ = defFieldFormat { fmtWidth = Just 19, fmtChar = 'd'} +#endif + toWord8 = dropDown . max 0 + {-# INLINE toWord8 #-} + toWord16 = dropDown . max 0 + {-# INLINE toWord16 #-} + toWord32 = dropDown . max 0 + {-# INLINE toWord32 #-} + toWord64 = fromIntegral . max 0 + {-# INLINE toWord64 #-} + toFloat = squashTo1 . max 0 + {-# INLINE toFloat #-} + toRealFloat = squashTo1 . max 0 + {-# INLINE toRealFloat #-} + fromRealFloat = stretch . clamp01 + {-# INLINE fromRealFloat #-} + + +-- | Values between @[0.0, 1.0]@ +instance Elevator Float where + maxValue = 1 + minValue = 0 + fieldFormat _ = defFieldFormat { fmtWidth = Just 9, fmtPrecision = Just 6, fmtChar = 'f'} + toWord8 = stretch . clamp01 + {-# INLINE toWord8 #-} + toWord16 = stretch . clamp01 + {-# INLINE toWord16 #-} + toWord32 = stretch . clamp01 + {-# INLINE toWord32 #-} + toWord64 = stretch . clamp01 + {-# INLINE toWord64 #-} + toFloat = id + {-# INLINE toFloat #-} + toDouble = float2Double + {-# INLINE toDouble #-} + fromDouble = toFloat + {-# INLINE fromDouble #-} + toRealFloat = uncurry encodeFloat . decodeFloat + {-# INLINE toRealFloat #-} + fromRealFloat = uncurry encodeFloat . decodeFloat + {-# INLINE fromRealFloat #-} + + +-- | Values between @[0.0, 1.0]@ +instance Elevator Double where + maxValue = 1 + minValue = 0 + fieldFormat _ = defFieldFormat { fmtWidth = Just 15, fmtPrecision = Just 12, fmtChar = 'f'} + toWord8 = stretch . clamp01 + {-# INLINE toWord8 #-} + toWord16 = stretch . clamp01 + {-# INLINE toWord16 #-} + toWord32 = stretch . clamp01 + {-# INLINE toWord32 #-} + toWord64 = stretch . clamp01 + {-# INLINE toWord64 #-} + toFloat = double2Float + {-# INLINE toFloat #-} + toDouble = id + {-# INLINE toDouble #-} + fromDouble = id + {-# INLINE fromDouble #-} + toRealFloat = uncurry encodeFloat . decodeFloat + {-# INLINE toRealFloat #-} + fromRealFloat = uncurry encodeFloat . decodeFloat + {-# INLINE fromRealFloat #-} + +{-# RULES +"toRealFloat :: Double -> Double / Float -> Float" toRealFloat = id +"toRealFloat :: Double -> Float" toRealFloat = double2Float +"toRealFloat :: Float -> Double" toRealFloat = float2Double +"fromRealFloat :: Double -> Double / Float -> Float" fromRealFloat = id +"fromRealFloat :: Double -> Float" fromRealFloat = double2Float +"fromRealFloat :: Float -> Double" fromRealFloat = float2Double + #-} + + +-- | Discards imaginary part and changes precision of real part. +instance (PrintfArg e, Elevator e, RealFloat e) => Elevator (Complex e) where + maxValue = maxValue :+ maxValue + minValue = minValue :+ minValue + toShowS (r :+ i) = toShowS r . formatArg i ((fieldFormat i) {fmtSign = Just SignPlus}) . ('i' :) + toWord8 = toWord8 . realPart + {-# INLINE toWord8 #-} + toWord16 = toWord16 . realPart + {-# INLINE toWord16 #-} + toWord32 = toWord32 . realPart + {-# INLINE toWord32 #-} + toWord64 = toWord64 . realPart + {-# INLINE toWord64 #-} + toFloat = toFloat . realPart + {-# INLINE toFloat #-} + toDouble = toDouble . realPart + {-# INLINE toDouble #-} + fromDouble = (:+ 0) . fromDouble + {-# INLINE fromDouble #-} + toRealFloat = toRealFloat . realPart + {-# INLINE toRealFloat #-} + fromRealFloat = (:+ 0) . fromRealFloat + {-# INLINE fromRealFloat #-} diff --git a/src/Graphics/Color/Illuminant/CIE1931.hs b/src/Graphics/Color/Illuminant/CIE1931.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Illuminant/CIE1931.hs @@ -0,0 +1,516 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE DataKinds #-} +-- | +-- Module : Graphics.Color.Illuminant.CIE1931 +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Illuminant.CIE1931 + ( CIE1931(..) + , wavelengths + , rectifyColorTemperature + ) where + +import Graphics.Color.Algebra +import Graphics.Color.Space.Internal + +rectifyColorTemperature :: + Int + -- ^ Original temperature + -> Double + -- ^ Original radiation constant c2 + -> CCT (i :: k) +rectifyColorTemperature cct c2 = CCT (fromIntegral cct * 1.4388 / c2) + + +-- | @[x=0.44758, y=0.40745]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'A where + type Temperature 'A = 2856 + whitePoint = WhitePoint 0.44758 0.40745 + colorTemperature = rectifyColorTemperature 2848 1.4350 + +-- | @[x=0.34842, y=0.35161]@ - CIE 1931 2° Observer - +-- /https://www.colour-science.org/ +instance Illuminant 'B where + type Temperature 'B = 4874 + whitePoint = WhitePoint 0.34842 0.35161 + +-- | @[x=0.31006, y=0.31616]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'C where + type Temperature 'C = 6774 + whitePoint = WhitePoint 0.31006 0.31616 + +-- | @[x=0.34567, y=0.35851]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'D50 where + type Temperature 'D50 = 5003 + whitePoint = WhitePoint 0.34567 0.35851 + colorTemperature = rectifyColorTemperature 5000 1.4380 + +-- | @[x=0.33243, y=0.34744]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'D55 where + type Temperature 'D55 = 5503 + whitePoint = WhitePoint 0.33243 0.34744 + colorTemperature = rectifyColorTemperature 5500 1.4380 + +-- | @[x=0.32163, y=0.33774]@ - CIE 1931 2° Observer - +-- /https://www.colour-science.org (rounded to 5 decimal points)/ +instance Illuminant 'D60 where + type Temperature 'D60 = 6003 + whitePoint = WhitePoint 0.32163 0.33774 + colorTemperature = rectifyColorTemperature 6000 1.4380 + +-- | @[x=0.31272, y=0.32903]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'D65 where + type Temperature 'D65 = 6504 + whitePoint = WhitePoint 0.31272 0.32903 + colorTemperature = rectifyColorTemperature 6500 1.4380 + +-- | @[x=0.29903, y=0.31488]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'D75 where + type Temperature 'D75 = 7504 + whitePoint = WhitePoint 0.29903 0.31488 + colorTemperature = rectifyColorTemperature 7500 1.4380 + +-- | @[x=1/3, y=1/3]@ - CIE 1931 2° Observer - +-- /https://www.colour-science.org/ +instance Illuminant 'E where + type Temperature 'E = 5454 + whitePoint = WhitePoint (1 / 3) (1 / 3) + + +-- | @[x=0.31310, y=0.33710]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL1 where + type Temperature 'FL1 = 6430 + whitePoint = WhitePoint 0.31310 0.33710 + +-- | @[x=0.37210, y=0.37510]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL2 where + type Temperature 'FL2 = 4230 + whitePoint = WhitePoint 0.37210 0.37510 + +-- | @[x=0.40910, y=0.39410]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3 where + type Temperature 'FL3 = 3450 + whitePoint = WhitePoint 0.40910 0.39410 + +-- | @[x=0.44020, y=0.40310]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL4 where + type Temperature 'FL4 = 2940 + whitePoint = WhitePoint 0.44020 0.40310 + +-- | @[x=0.31380, y=0.34520]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL5 where + type Temperature 'FL5 = 6350 + whitePoint = WhitePoint 0.31380 0.34520 + +-- | @[x=0.37790, y=0.38820]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL6 where + type Temperature 'FL6 = 4150 + whitePoint = WhitePoint 0.37790 0.38820 + +-- | @[x=0.31290, y=0.32920]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL7 where + type Temperature 'FL7 = 6500 + whitePoint = WhitePoint 0.31290 0.32920 + +-- | @[x=0.34580, y=0.35860]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL8 where + type Temperature 'FL8 = 5000 + whitePoint = WhitePoint 0.34580 0.35860 + +-- | @[x=0.37410, y=0.37270]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL9 where + type Temperature 'FL9 = 4150 + whitePoint = WhitePoint 0.37410 0.37270 + +-- | @[x=0.34580, y=0.35880]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL10 where + type Temperature 'FL10 = 5000 + whitePoint = WhitePoint 0.34580 0.35880 + +-- | @[x=0.38050, y=0.37690]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL11 where + type Temperature 'FL11 = 4000 + whitePoint = WhitePoint 0.38050 0.37690 + +-- | @[x=0.43700, y=0.40420]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL12 where + type Temperature 'FL12 = 3000 + whitePoint = WhitePoint 0.43700 0.40420 + + +-- | @[x=0.44070, y=0.40330]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_1 where + type Temperature 'FL3_1 = 2932 + whitePoint = WhitePoint 0.44070 0.40330 + +-- | @[x=0.38080, y=0.37340]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_2 where + type Temperature 'FL3_2 = 3965 + whitePoint = WhitePoint 0.38080 0.37340 + +-- | @[x=0.31530, y=0.34390]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_3 where + type Temperature 'FL3_3 = 6280 + whitePoint = WhitePoint 0.31530 0.34390 + +-- | @[x=0.44290, y=0.40430]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_4 where + type Temperature 'FL3_4 = 2904 + whitePoint = WhitePoint 0.44290 0.40430 + +-- | @[x=0.37490, y=0.36720]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_5 where + type Temperature 'FL3_5 = 4086 + whitePoint = WhitePoint 0.37490 0.36720 + +-- | @[x=0.34880, y=0.36000]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_6 where + type Temperature 'FL3_6 = 4894 + whitePoint = WhitePoint 0.34880 0.36000 + +-- | @[x=0.43840, y=0.40450]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_7 where + type Temperature 'FL3_7 = 2979 + whitePoint = WhitePoint 0.43840 0.40450 + +-- | @[x=0.38200, y=0.38320]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_8 where + type Temperature 'FL3_8 = 4006 + whitePoint = WhitePoint 0.38200 0.38320 + +-- | @[x=0.34990, y=0.35910]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_9 where + type Temperature 'FL3_9 = 4853 + whitePoint = WhitePoint 0.34990 0.35910 + +-- | @[x=0.34550, y=0.35600]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_10 where + type Temperature 'FL3_10 = 5000 + whitePoint = WhitePoint 0.34550 0.35600 + +-- | @[x=0.32450, y=0.34340]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_11 where + type Temperature 'FL3_11 = 5854 + whitePoint = WhitePoint 0.32450 0.34340 + +-- | @[x=0.43770, y=0.40370]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_12 where + type Temperature 'FL3_12 = 2984 + whitePoint = WhitePoint 0.43770 0.40370 + +-- | @[x=0.38300, y=0.37240]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_13 where + type Temperature 'FL3_13 = 3896 + whitePoint = WhitePoint 0.38300 0.37240 + +-- | @[x=0.34470, y=0.36090]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_14 where + type Temperature 'FL3_14 = 5045 + whitePoint = WhitePoint 0.34470 0.36090 + +-- | @[x=0.31270, y=0.32880]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3_15 where + type Temperature 'FL3_15 = 6509 + whitePoint = WhitePoint 0.31270 0.32880 + + +-- | @[x=0.53300, y=0.41500]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'HP1 where + type Temperature 'HP1 = 1959 + whitePoint = WhitePoint 0.53300 0.41500 + +-- | @[x=0.47780, y=0.41580]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'HP2 where + type Temperature 'HP2 = 2506 + whitePoint = WhitePoint 0.47780 0.41580 + +-- | @[x=0.43020, y=0.40750]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'HP3 where + type Temperature 'HP3 = 3144 + whitePoint = WhitePoint 0.43020 0.40750 + +-- | @[x=0.38120, y=0.37970]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'HP4 where + type Temperature 'HP4 = 4002 + whitePoint = WhitePoint 0.38120 0.37970 + +-- | @[x=0.37760, y=0.37130]@ - CIE 1931 2° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'HP5 where + type Temperature 'HP5 = 4039 + whitePoint = WhitePoint 0.37760 0.37130 + + +-- | CIE 1931 2° observer illuminants +-- +-- References: +-- +-- * [CIE15: Technical Report: Colorimetry, 3rd edition](https://web.archive.org/web/20190510201823/https://www.cdvplus.cz/file/3-publikace-cie15-2004/) +-- * [HunterLab: Equivalent White Light Sources and CIE Illuminants](https://web.archive.org/web/20050523033826/http://www.hunterlab.com:80/appnotes/an05_05.pdf) + +data CIE1931 + = A + -- ^ Incandescent / Tungsten + | B + -- ^ Direct sunlight at noon (obsolete) + | C + -- ^ Average / North sky Daylight (obsolete) + | D50 + -- ^ Horizon Light. + | D55 + -- ^ Mid-morning / Mid-afternoon Daylight + | D60 + | D65 + -- ^ Noon Daylight + | D75 + -- ^ Overcast dayligh / North sky Daylight + | E + -- ^ Equal energy + | FL1 + -- ^ Daylight Fluorescent + | FL2 + -- ^ The fluorescent illuminant in most common use, represents cool white fluorescent + -- (4100° Kelvin, CRI 60). Non-standard names include F, F02, Fcw, CWF, CWF2. + -- + -- /Note/ - Takes precedence over other F illuminants + | FL3 + -- ^ White Fluorescent + | FL4 + -- ^ Warm White Fluorescent + | FL5 + -- ^ Daylight Fluorescent + | FL6 + -- ^ Lite White Fluorescent + | FL7 + -- ^ Represents a broadband fluorescent lamp, which approximates CIE illuminant `D65` + -- (6500° Kelvin, CRI 90). + -- + -- /Note/ - Takes precedence over other F illuminants + | FL8 + -- ^ `D50` simulator, Sylvania F40 Design 50 (F40DSGN50) + | FL9 + -- ^ Cool White Deluxe Fluorescent + | FL10 + -- ^ Philips TL85, Ultralume 50 + | FL11 + -- ^ Philips TL84, SP41, Ultralume 40 + -- + -- Represents a narrow tri-band fluorescent of 4000° Kelvin color temperature, CRI 83. + -- + -- /Note/ - Takes precedence over other F illuminants + | FL12 + -- ^ Philips TL83, Ultralume 30 + | FL3_1 + -- ^ Standard halophosphate lamp (New set of fluorescent lamps) + | FL3_2 + -- ^ Standard halophosphate lamp (New set of fluorescent lamps) + | FL3_3 + -- ^ Standard halophosphate lamp (New set of fluorescent lamps) + | FL3_4 + -- ^ Deluxe type lamp (New set of fluorescent lamps) + | FL3_5 + -- ^ Deluxe type lamp (New set of fluorescent lamps) + | FL3_6 + -- ^ Deluxe type lamp (New set of fluorescent lamps) + | FL3_7 + -- ^ Three band fluorescent lamp (New set of fluorescent lamps) + | FL3_8 + -- ^ Three band fluorescent lamp (New set of fluorescent lamps) + | FL3_9 + -- ^ Three band fluorescent lamp (New set of fluorescent lamps) + | FL3_10 + -- ^ Three band fluorescent lamp (New set of fluorescent lamps) + | FL3_11 + -- ^ Three band fluorescent lamp (New set of fluorescent lamps) + | FL3_12 + -- ^ Multi-band fluorescent lamp (New set of fluorescent lamps) + | FL3_13 + -- ^ Multi-band fluorescent lamp (New set of fluorescent lamps) + | FL3_14 + -- ^ Multi-band fluorescent lamp (New set of fluorescent lamps) + | FL3_15 + -- ^ `D65` simulator lamp (New set of fluorescent lamps) + | HP1 + -- ^ Standard high pressure sodium lamp + | HP2 + -- ^ Colour enhanced high pressure sodium lamp + | HP3 + -- ^ High pressure metal halide lamp + | HP4 + -- ^ High pressure metal halide lamp + | HP5 + -- ^ High pressure metal halide lamp + deriving (Eq, Show, Enum) + +-- -- | Academy Color Encoding System +-- data ACES = +-- ACES +-- deriving (Eq, Show) + +-- instance Illuminant 'ACES where +-- whitePoint = WhitePoint 0.32168 0.33767 + + +-- Move into it's own module + +-- -- | [DCI-P3](https://en.wikipedia.org/wiki/DCI-P3) is a color space from the American film industry +-- data DCI_P3 = DCI_P3 + +-- instance Illuminant 'DCI_P3 where +-- whitePoint = WhitePoint 0.314 0.351 + + + +wavelengths :: [(Double, V3 Double)] +wavelengths = + [ (300, V3 0.04 0.02 0.00) + , (305, V3 3.02 2.26 1.00) + , (310, V3 6.00 4.50 2.00) + , (315, V3 17.80 13.45 3.00) + , (320, V3 29.60 22.40 4.00) + , (325, V3 42.45 32.20 6.25) + , (330, V3 55.30 42.00 8.50) + , (335, V3 56.30 41.30 8.15) + , (340, V3 57.30 40.60 7.80) + , (345, V3 59.55 41.10 7.25) + , (350, V3 61.80 41.60 6.70) + , (355, V3 61.65 39.80 6.00) + , (360, V3 61.50 38.00 5.30) + , (365, V3 65.15 40.20 5.70) + , (370, V3 68.80 42.40 6.10) + , (375, V3 66.10 40.45 4.55) + , (380, V3 63.40 38.50 3.00) + , (385, V3 64.60 36.75 2.10) + , (390, V3 65.80 35.00 1.20) + , (395, V3 80.30 39.20 0.05) + , (400, V3 94.80 43.40 -1.10) + , (405, V3 99.80 44.85 -0.80) + , (410, V3 104.80 46.30 -0.50) + , (415, V3 105.35 45.10 -0.60) + , (420, V3 105.90 43.90 -0.70) + , (425, V3 101.35 40.50 -0.95) + , (430, V3 96.80 37.10 -1.20) + , (435, V3 105.35 36.90 -1.90) + , (440, V3 113.90 36.70 -2.60) + , (445, V3 119.75 36.30 -2.75) + , (450, V3 125.60 35.90 -2.90) + , (455, V3 125.55 34.25 -2.85) + , (460, V3 125.50 32.60 -2.80) + , (465, V3 123.40 30.25 -2.70) + , (470, V3 121.30 27.90 -2.60) + , (475, V3 121.30 26.10 -2.60) + , (480, V3 121.30 24.30 -2.60) + , (485, V3 117.40 22.20 -2.20) + , (490, V3 113.50 20.10 -1.80) + , (495, V3 113.30 18.15 -1.65) + , (500, V3 113.10 16.20 -1.50) + , (505, V3 111.95 14.70 -1.40) + , (510, V3 110.80 13.20 -1.30) + , (515, V3 108.65 10.90 -1.25) + , (520, V3 106.50 8.60 -1.20) + , (525, V3 107.65 7.35 -1.10) + , (530, V3 108.80 6.10 -1.00) + , (535, V3 107.05 5.15 -0.75) + , (540, V3 105.30 4.20 -0.50) + , (545, V3 104.85 3.05 -0.40) + , (550, V3 104.40 1.90 -0.30) + , (555, V3 102.20 0.95 -0.15) + , (560, V3 100.00 0.00 0.00) + , (565, V3 98.00 -0.80 0.10) + , (570, V3 96.00 -1.60 0.20) + , (575, V3 95.55 -2.55 0.35) + , (580, V3 95.10 -3.50 0.50) + , (585, V3 92.10 -3.50 1.30) + , (590, V3 89.10 -3.50 2.10) + , (595, V3 89.80 -4.65 2.65) + , (600, V3 90.50 -5.80 3.20) + , (605, V3 90.40 -6.50 3.65) + , (610, V3 90.30 -7.20 4.10) + , (615, V3 89.35 -7.90 4.40) + , (620, V3 88.40 -8.60 4.70) + , (625, V3 86.20 -9.05 4.90) + , (630, V3 84.00 -9.50 5.10) + , (635, V3 84.55 -10.20 5.90) + , (640, V3 85.10 -10.90 6.70) + , (645, V3 83.50 -10.80 7.00) + , (650, V3 81.90 -10.70 7.30) + , (655, V3 82.25 -11.35 7.95) + , (660, V3 82.60 -12.00 8.60) + , (665, V3 83.75 -13.00 9.20) + , (670, V3 84.90 -14.00 9.80) + , (675, V3 83.10 -13.80 10.00) + , (680, V3 81.30 -13.60 10.20) + , (685, V3 76.60 -12.80 9.25) + , (690, V3 71.90 -12.00 8.30) + , (695, V3 73.10 -12.65 8.95) + , (700, V3 74.30 -13.30 9.60) + , (705, V3 75.35 -13.10 9.05) + , (710, V3 76.40 -12.90 8.50) + , (715, V3 69.85 -11.75 7.75) + , (720, V3 63.30 -10.60 7.00) + , (725, V3 67.50 -11.10 7.30) + , (730, V3 71.70 -11.60 7.60) + , (735, V3 74.35 -11.90 7.80) + , (740, V3 77.00 -12.20 8.00) + , (745, V3 71.10 -11.20 7.35) + , (750, V3 65.20 -10.20 6.70) + , (755, V3 56.45 -9.00 5.95) + , (760, V3 47.70 -7.80 5.20) + , (765, V3 58.15 -9.50 6.30) + , (770, V3 68.60 -11.20 7.40) + , (775, V3 66.80 -10.80 7.10) + , (780, V3 65.00 -10.40 6.80) + , (785, V3 65.50 -10.50 6.90) + , (790, V3 66.00 -10.60 7.00) + , (795, V3 63.50 -10.15 6.70) + , (800, V3 61.00 -9.70 6.40) + , (805, V3 57.15 -9.00 5.95) + , (810, V3 53.30 -8.30 5.50) + , (815, V3 56.10 -8.80 5.80) + , (820, V3 58.90 -9.30 6.10) + , (825, V3 60.40 -9.55 6.30) + , (830, V3 61.90 -9.80 6.50) + ] diff --git a/src/Graphics/Color/Illuminant/CIE1964.hs b/src/Graphics/Color/Illuminant/CIE1964.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Illuminant/CIE1964.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Illuminant.CIE1964 +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Illuminant.CIE1964 + ( CIE1964(..) + ) where + +import Graphics.Color.Space.Internal (Illuminant(..), WhitePoint(..)) +import qualified Graphics.Color.Illuminant.CIE1931 as I2 + + +-- | @[x=0.45117, y=0.40594]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'A where + type Temperature 'A = 2856 + whitePoint = WhitePoint 0.45117 0.40594 + colorTemperature = I2.rectifyColorTemperature 2848 1.4350 + +-- | @[x=0.34980, y=0.35270]@ - CIE 1964 10° Observer - +-- /https://www.colour-science.org/ +instance Illuminant 'B where + type Temperature 'B = 4874 + whitePoint = WhitePoint 0.34980 0.35270 + +-- | @[x=0.31039, y=0.31905]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'C where + type Temperature 'C = 6774 + whitePoint = WhitePoint 0.31039 0.31905 + +-- | @[x=0.34773, y=0.35952]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'D50 where + type Temperature 'D50 = 5003 + whitePoint = WhitePoint 0.34773 0.35952 + colorTemperature = I2.rectifyColorTemperature 5000 1.4380 + +-- | @[x=0.33412, y=0.34877]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'D55 where + type Temperature 'D55 = 5503 + whitePoint = WhitePoint 0.33412 0.34877 + colorTemperature = I2.rectifyColorTemperature 5500 1.4380 + +-- | @[x=0.32299, y=0.33928]@ - CIE 1964 10° Observer - +-- /https://www.colour-science.org (rounded to 5 decimal points)/ +instance Illuminant 'D60 where + type Temperature 'D60 = 6003 + whitePoint = WhitePoint 0.32299 0.33928 + colorTemperature = I2.rectifyColorTemperature 6000 1.4380 + +-- | @[x=0.31381, y=0.33098]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'D65 where + type Temperature 'D65 = 6504 + whitePoint = WhitePoint 0.31381 0.33098 + colorTemperature = I2.rectifyColorTemperature 6500 1.4380 + +-- | @[x=0.29968, y=0.31740]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'D75 where + type Temperature 'D75 = 7504 + whitePoint = WhitePoint 0.29968 0.31740 + colorTemperature = I2.rectifyColorTemperature 7500 1.4380 + +-- | @[x=1/3, y=1/3]@ - CIE 1964 10° Observer - +-- /https://www.colour-science.org/ +instance Illuminant 'E where + type Temperature 'E = 5454 + whitePoint = WhitePoint (1 / 3) (1 / 3) + +-- | @[x=0.31811, y=0.33559]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL1 where + type Temperature 'FL1 = 6430 + whitePoint = WhitePoint 0.31811 0.33559 + +-- | @[x=0.37925, y=0.36733]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL2 where + type Temperature 'FL2 = 4230 + whitePoint = WhitePoint 0.37925 0.36733 + +-- | @[x=0.41761, y=0.38324]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL3 where + type Temperature 'FL3 = 3450 + whitePoint = WhitePoint 0.41761 0.38324 + +-- | @[x=0.44920, y=0.39074]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL4 where + type Temperature 'FL4 = 2940 + whitePoint = WhitePoint 0.44920 0.39074 + +-- | @[x=0.31975, y=0.34246]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL5 where + type Temperature 'FL5 = 6350 + whitePoint = WhitePoint 0.31975 0.34246 + +-- | @[x=0.38660, y=0.37847]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL6 where + type Temperature 'FL6 = 4150 + whitePoint = WhitePoint 0.38660 0.37847 + +-- | @[x=0.31569, y=0.32960]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL7 where + type Temperature 'FL7 = 6500 + whitePoint = WhitePoint 0.31569 0.32960 + +-- | @[x=0.34902, y=0.35939]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL8 where + type Temperature 'FL8 = 5000 + whitePoint = WhitePoint 0.34902 0.35939 + +-- | @[x=0.37829, y=0.37045]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL9 where + type Temperature 'FL9 = 4150 + whitePoint = WhitePoint 0.37829 0.37045 + +-- | @[x=0.35090, y=0.35444]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL10 where + type Temperature 'FL10 = 5000 + whitePoint = WhitePoint 0.35090 0.35444 + +-- | @[x=0.38541, y=0.37123]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL11 where + type Temperature 'FL11 = 4000 + whitePoint = WhitePoint 0.38541 0.37123 + +-- | @[x=0.44256, y=0.39717]@ - CIE 1964 10° Observer - +-- /CIE15: Technical Report: Colorimetry, 3rd edition/ +instance Illuminant 'FL12 where + type Temperature 'FL12 = 3000 + whitePoint = WhitePoint 0.44256 0.39717 + + +-- | CIE 1964 10° observer illuminants +-- +-- References: +-- +-- * [CIE15: Technical Report: Colorimetry, 3rd edition](https://web.archive.org/web/20190510201823/https://www.cdvplus.cz/file/3-publikace-cie15-2004/) + +data CIE1964 + = A + -- ^ Incandescent / Tungsten + | B + -- ^ Direct sunlight at noon (obsolete) + | C + -- ^ Average / North sky Daylight (obsolete) + | D50 + -- ^ Horizon Light. + | D55 + -- ^ Mid-morning / Mid-afternoon Daylight + | D60 + | D65 + -- ^ Noon Daylight + | D75 + -- ^ Overcast dayligh / North sky Daylight + | E + -- ^ Equal energy + | FL1 + -- ^ Daylight Fluorescent + | FL2 + -- ^ The fluorescent illuminant in most common use, represents cool white fluorescent + -- (4100° Kelvin, CRI 60). Non-standard names include F, F02, Fcw, CWF, CWF2. + -- + -- /Note/ - Takes precedence over other F illuminants + | FL3 + -- ^ White Fluorescent + | FL4 + -- ^ Warm White Fluorescent + | FL5 + -- ^ Daylight Fluorescent + | FL6 + -- ^ Lite White Fluorescent + | FL7 + -- ^ Represents a broadband fluorescent lamp, which approximates CIE illuminant `D65` + -- (6500° Kelvin, CRI 90). + -- + -- /Note/ - Takes precedence over other F illuminants + | FL8 + -- ^ `D50` simulator, Sylvania F40 Design 50 (F40DSGN50) + | FL9 + -- ^ Cool White Deluxe Fluorescent + | FL10 + -- ^ Philips TL85, Ultralume 50 + | FL11 + -- ^ Philips TL84, SP41, Ultralume 40 + -- + -- Represents a narrow tri-band fluorescent of 4000° Kelvin color temperature, CRI 83. + -- + -- /Note/ - Takes precedence over other F illuminants + | FL12 + -- ^ Philips TL83, Ultralume 30 + deriving (Eq, Show, Enum) diff --git a/src/Graphics/Color/Illuminant/ICC/PCS.hs b/src/Graphics/Color/Illuminant/ICC/PCS.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Illuminant/ICC/PCS.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE DataKinds #-} +-- | +-- Module : Graphics.Color.Illuminant.ICC.PCS +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Illuminant.ICC.PCS + ( D50 + ) where + +import Graphics.Color.Space.Internal + +-- | This is an approximation of CIE1931 `Graphics.ColorSpace.Illuminant.CIE1931.'D50` +-- white point defined in ICC PCS. Useful for chromatic adaptation. +data D50 + +-- | Tristimulus @[X=0.9642, Y=1.0000, Z=0.8249]@ - /IEC 61966-2-1:1999/, /ICC PCS/ +instance Illuminant D50 where + type Temperature D50 = 5003 + whitePoint = WhitePoint 0.345702914919 0.358538596680 diff --git a/src/Graphics/Color/Illuminant/ITU/Rec470.hs b/src/Graphics/Color/Illuminant/ITU/Rec470.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Illuminant/ITU/Rec470.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE DataKinds #-} +-- | +-- Module : Graphics.Color.Illuminant.ITU.Rec470 +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Illuminant.ITU.Rec470 + ( C + , D65 + ) where + +import Graphics.Color.Space.Internal + + + +-- | Whitepoint C that is used for ITU: Rec.470 (525). It is slightly different than the +-- one defined by CIE1931, thus a separate daclaration in here. +data C + + +-- | @[x=0.310, y=0.316]@ - /Rec. ITU-R BT.470-7/ +instance Illuminant C where + type Temperature C = 6774 + whitePoint = WhitePoint 0.310 0.316 + + + +-- ^ Whitepoint D65 that is used for ITU: Rec.470 (625). It is slightly different than the +-- one defined by CIE1931 and the one in Rec.601, thus a separate declaration in here. +data D65 + + +-- | @[x=0.313, y=0.329]@ - /Rec. ITU-R BT.470-7/ +instance Illuminant D65 where + type Temperature D65 = 6504 + whitePoint = WhitePoint 0.313 0.329 diff --git a/src/Graphics/Color/Illuminant/ITU/Rec601.hs b/src/Graphics/Color/Illuminant/ITU/Rec601.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Illuminant/ITU/Rec601.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE DataKinds #-} +-- | +-- Module : Graphics.Color.Illuminant.ITU.Rec601 +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Illuminant.ITU.Rec601 + ( D65 + ) where + +import Graphics.Color.Space.Internal + +-- | Whitepoint D65 that is so commonly used for sRGB and other color spaces defined by +-- ITU: Rec.601 (525 and 625) and Rec.709 standards. It is slightly different than the +-- one defined by CIE1931, thus a separate daclaration in here. +data D65 + +-- | @[x=0.3127, y=0.3290]@ - /Rec. ITU-R BT.601-7/, /Rec. ITU-R BT.709-6/, /IEC 61966-2-1:1999/ +instance Illuminant D65 where + type Temperature D65 = 6504 + whitePoint = WhitePoint 0.3127 0.3290 diff --git a/src/Graphics/Color/Model.hs b/src/Graphics/Color/Model.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model.hs @@ -0,0 +1,49 @@ +-- | +-- Module : Graphics.Color.Model +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model + ( ColorModel(..) + -- * Alpha + , Alpha + , Opaque + , addAlpha + , getAlpha + , setAlpha + , dropAlpha + , modifyOpaque + -- * Y + , module Graphics.Color.Model.Y + -- * RGB + , module Graphics.Color.Model.RGB + -- * HSI + , module Graphics.Color.Model.HSI + -- * HSL + , module Graphics.Color.Model.HSL + -- * HSV + , module Graphics.Color.Model.HSV + -- * YCbCr + , module Graphics.Color.Model.YCbCr + -- * CMYK + , module Graphics.Color.Model.CMYK + -- * Color + , Color(..) + , module Graphics.Color.Algebra.Binary + , module Graphics.Color.Algebra.Elevator + ) where + +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.CMYK +import Graphics.Color.Model.HSI +import Graphics.Color.Model.HSL +import Graphics.Color.Model.HSV +import Graphics.Color.Model.Internal +import Graphics.Color.Model.RGB +import Graphics.Color.Model.Y +import Graphics.Color.Model.YCbCr +import Graphics.Color.Algebra.Binary +import Graphics.Color.Algebra.Elevator diff --git a/src/Graphics/Color/Model/Alpha.hs b/src/Graphics/Color/Model/Alpha.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model/Alpha.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Model.Alpha +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model.Alpha + ( Alpha + , Opaque + , addAlpha + , getAlpha + , setAlpha + , dropAlpha + , modifyAlpha + , modifyOpaque + , Color(Alpha) + , ColorModel(..) + ) where + +import Foreign.Ptr +import Foreign.Storable +import Graphics.Color.Model.Internal +import GHC.TypeLits +import Data.Proxy + +data Alpha cs + +data instance Color (Alpha cs) e = Alpha + { _opaque :: !(Color cs e) + , _alpha :: !e + } + +-- | Get the alpha channel value for the pixel +-- +-- @since 0.1.0 +getAlpha :: Color (Alpha cs) e -> e +getAlpha = _alpha +{-# INLINE getAlpha #-} + +-- | Get the opaque pixel value, while leaving alpha channel intact. +-- +-- @since 0.1.0 +dropAlpha :: Color (Alpha cs) e -> Color cs e +dropAlpha = _opaque +{-# INLINE dropAlpha #-} + +-- | Add an alpha channel value to an opaque pixel +-- +-- @since 0.1.0 +addAlpha :: Color cs e -> e -> Color (Alpha cs) e +addAlpha = Alpha +{-# INLINE addAlpha #-} + +-- | Change the alpha channel value for the pixel +-- +-- @since 0.1.0 +setAlpha :: Color (Alpha cs) e -> e -> Color (Alpha cs) e +setAlpha px a = px { _alpha = a } +{-# INLINE setAlpha #-} + +-- | Change the alpha channel value for the pixel +-- +-- @since 0.1.0 +modifyAlpha :: (e -> e) -> Color (Alpha cs) e -> Color (Alpha cs) e +modifyAlpha f px = px { _alpha = f (_alpha px) } +{-# INLINE modifyAlpha #-} + +-- | Change the opaque pixel value, while leaving alpha channel intact. +-- +-- @since 0.1.0 +modifyOpaque :: (Color cs e -> Color cs' e) -> Color (Alpha cs) e -> Color (Alpha cs') e +modifyOpaque fpx pxa = pxa { _opaque = fpx (_opaque pxa) } +{-# INLINE modifyOpaque #-} + +instance (Eq (Color cs e), Eq e) => Eq (Color (Alpha cs) e) where + (==) (Alpha px1 a1) (Alpha px2 a2) = px1 == px2 && a1 == a2 + {-# INLINE (==) #-} + +instance (ColorModel cs e, Opaque (Alpha cs) ~ cs) => Show (Color (Alpha cs) e) where + showsPrec _ = showsColorModel + +type family Opaque cs where + Opaque (Alpha (Alpha cs)) = TypeError ('Text "Nested alpha channels are not allowed") + Opaque (Alpha cs) = cs + Opaque cs = cs + +instance (ColorModel cs e, Opaque (Alpha cs) ~ cs) => ColorModel (Alpha cs) e where + type Components (Alpha cs) e = (Components cs e, e) + toComponents (Alpha px a) = (toComponents px, a) + {-# INLINE toComponents #-} + fromComponents (pxc, a) = Alpha (fromComponents pxc) a + {-# INLINE fromComponents #-} + showsColorModelName _ = showsColorModelName (Proxy :: Proxy (Color cs e)) . ('A':) + + +instance Functor (Color cs) => Functor (Color (Alpha cs)) where + fmap f (Alpha px a) = Alpha (fmap f px) (f a) + {-# INLINE fmap #-} + +instance Applicative (Color cs) => Applicative (Color (Alpha cs)) where + pure e = Alpha (pure e) e + {-# INLINE pure #-} + (Alpha fpx fa) <*> (Alpha px a) = Alpha (fpx <*> px) (fa a) + {-# INLINE (<*>) #-} + +instance Foldable (Color cs) => Foldable (Color (Alpha cs)) where + foldr f acc (Alpha px a) = foldr f (f a acc) px + {-# INLINE foldr #-} + foldr1 f (Alpha px a) = foldr f a px + {-# INLINE foldr1 #-} + +instance Traversable (Color cs) => Traversable (Color (Alpha cs)) where + traverse f (Alpha px a) = Alpha <$> traverse f px <*> f a + {-# INLINE traverse #-} + +instance (Storable (Color cs e), Storable e) => Storable (Color (Alpha cs) e) where + sizeOf _ = sizeOf (undefined :: Color cs e) + sizeOf (undefined :: e) + {-# INLINE sizeOf #-} + alignment _ = alignment (undefined :: e) + {-# INLINE alignment #-} + peek ptr = do + px <- peek (castPtr ptr) + Alpha px <$> peekByteOff ptr (sizeOf px) + {-# INLINE peek #-} + poke ptr (Alpha px a) = do + poke (castPtr ptr) px + pokeByteOff ptr (sizeOf px) a + {-# INLINE poke #-} diff --git a/src/Graphics/Color/Model/CMYK.hs b/src/Graphics/Color/Model/CMYK.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model/CMYK.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Model.CMYK +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model.CMYK + ( CMYK + -- * Constructors for an CMYK color model. + , pattern ColorCMYK + , pattern ColorCMYKA + , Color + , ColorModel(..) + , cmyk2rgb + , rgb2cmyk + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import Graphics.Color.Model.RGB + +------------ +--- CMYK --- +------------ + +data CMYK + +-- | `CMYK` color model +data instance Color CMYK e = ColorCMYK !e !e !e !e + +-- | Constructor for @CMYK@ with alpha channel. +pattern ColorCMYKA :: e -> e -> e -> e -> e -> Color (Alpha CMYK) e +pattern ColorCMYKA c m y k a = Alpha (ColorCMYK c m y k) a +{-# COMPLETE ColorCMYKA #-} + +-- | `CMYK` color model +deriving instance Eq e => Eq (Color CMYK e) +-- | `CMYK` color model +deriving instance Ord e => Ord (Color CMYK e) + +-- | `CMYK` color model +instance Elevator e => Show (Color CMYK e) where + showsPrec _ = showsColorModel + +-- | `CMYK` color model +instance Elevator e => ColorModel CMYK e where + type Components CMYK e = (e, e, e, e) + toComponents (ColorCMYK c m y k) = (c, m, y, k) + {-# INLINE toComponents #-} + fromComponents (c, m, y, k) = ColorCMYK c m y k + {-# INLINE fromComponents #-} + +-- | `CMYK` color model +instance Functor (Color CMYK) where + fmap f (ColorCMYK c m y k) = ColorCMYK (f c) (f m) (f y) (f k) + {-# INLINE fmap #-} + +-- | `CMYK` color model +instance Applicative (Color CMYK) where + pure !e = ColorCMYK e e e e + {-# INLINE pure #-} + (ColorCMYK fc fm fy fk) <*> (ColorCMYK c m y k) = ColorCMYK (fc c) (fm m) (fy y) (fk k) + {-# INLINE (<*>) #-} + +-- | `CMYK` color model +instance Foldable (Color CMYK) where + foldr f !z (ColorCMYK c m y k) = f c (f m (f y (f k z))) + {-# INLINE foldr #-} + +-- | `CMYK` color model +instance Traversable (Color CMYK) where + traverse f (ColorCMYK c m y k) = ColorCMYK <$> f c <*> f m <*> f y <*> f k + {-# INLINE traverse #-} + +-- | `CMYK` color model +instance Storable e => Storable (Color CMYK e) where + sizeOf = sizeOfN 4 + {-# INLINE sizeOf #-} + alignment = alignmentN 4 + {-# INLINE alignment #-} + peek = peek4 ColorCMYK + {-# INLINE peek #-} + poke p (ColorCMYK c m y k) = poke4 p c m y k + {-# INLINE poke #-} + +cmyk2rgb :: Num e => Color CMYK e -> Color RGB e +cmyk2rgb (ColorCMYK c m y k) = ColorRGB r g b + where + !r = (1 - c) * (1 - k) + !g = (1 - m) * (1 - k) + !b = (1 - y) * (1 - k) +{-# INLINE cmyk2rgb #-} + + +rgb2cmyk :: (Ord e, Fractional e) => Color RGB e -> Color CMYK e +rgb2cmyk (ColorRGB r g b) = ColorCMYK c m y k + where + !c = (k' - r) / k' + !m = (k' - g) / k' + !y = (k' - b) / k' + !k = 1 - k' + !k' = max r (max g b) +{-# INLINE rgb2cmyk #-} diff --git a/src/Graphics/Color/Model/HSI.hs b/src/Graphics/Color/Model/HSI.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model/HSI.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Color.Model.HSI +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model.HSI + ( HSI + -- * Constructors for an HSI color model. + , pattern ColorHSI + , pattern ColorHSIA + , pattern ColorH360SI + , Color + , ColorModel(..) + , hsi2rgb + , rgb2hsi + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import Graphics.Color.Model.RGB + +----------- +--- HSI --- +----------- + +-- | Hue, Saturation and Intensity color model. +data HSI + +-- | `HSI` color model +newtype instance Color HSI e = HSI (V3 e) + +-- | Constructor for @HSI@. +pattern ColorHSI :: e -> e -> e -> Color HSI e +pattern ColorHSI h s i = HSI (V3 h s i) +{-# COMPLETE ColorHSI #-} + + +-- | Constructor for @HSI@ with alpha channel. +pattern ColorHSIA :: e -> e -> e -> e -> Color (Alpha HSI) e +pattern ColorHSIA h s i a = Alpha (ColorHSI h s i) a +{-# COMPLETE ColorHSIA #-} + +-- | Constructor for an HSI color model. Difference from `ColorHSI` is that channels are +-- restricted to `Double` and the hue is specified in 0 to 360 degree range, rather than 0 +-- to 1. Note, that this is not checked. +pattern ColorH360SI :: Double -> Double -> Double -> Color HSI Double +pattern ColorH360SI h s i <- ColorHSI ((* 360) -> h) s i where + ColorH360SI h s i = ColorHSI (h / 360) s i +{-# COMPLETE ColorH360SI #-} + + +-- | `HSI` color model +deriving instance Eq e => Eq (Color HSI e) +-- | `HSI` color model +deriving instance Ord e => Ord (Color HSI e) +-- | `HSI` color model +deriving instance Functor (Color HSI) +-- | `HSI` color model +deriving instance Applicative (Color HSI) +-- | `HSI` color model +deriving instance Foldable (Color HSI) +-- | `HSI` color model +deriving instance Traversable (Color HSI) +-- | `HSI` color model +deriving instance Storable e => Storable (Color HSI e) + +-- | `HSI` color model +instance Elevator e => Show (Color HSI e) where + showsPrec _ = showsColorModel + +-- | `HSI` color model +instance Elevator e => ColorModel HSI e where + type Components HSI e = (e, e, e) + toComponents (ColorHSI h s i) = (h, s, i) + {-# INLINE toComponents #-} + fromComponents (h, s, i) = ColorHSI h s i + {-# INLINE fromComponents #-} + + +hsi2rgb :: (Ord e, Floating e) => Color HSI e -> Color RGB e +hsi2rgb (ColorHSI h' s i) = getRGB (h' * 2 * pi) + where + !is = i * s + !second = i - is + !pi3 = pi / 3 + getFirst !a !b = i + is * cos a / cos b + {-# INLINE getFirst #-} + getThird !v1 !v2 = i + 2 * is + v1 - v2 + {-# INLINE getThird #-} + getRGB h + | h < 0 = ColorRGB 0 0 0 + | h < 2 * pi3 = + let !r = getFirst h (pi3 - h) + !b = second + !g = getThird b r + in ColorRGB r g b + | h < 4 * pi3 = + let !g = getFirst (h - 2 * pi3) (h + pi) + !r = second + !b = getThird r g + in ColorRGB r g b + | h < 2 * pi = + let !b = getFirst (h - 4 * pi3) (2 * pi - pi3 - h) + !g = second + !r = getThird g b + in ColorRGB r g b + | otherwise = ColorRGB 0 0 0 + {-# INLINE getRGB #-} +{-# INLINE hsi2rgb #-} + + +rgb2hsi :: RealFloat e => Color RGB e -> Color HSI e +rgb2hsi (ColorRGB r g b) = ColorHSI h s i + where + !h' = atan2 y x + !h'2pi = h' / (2 * pi) + !h + | h' < 0 = h'2pi + 1 + | otherwise = h'2pi + !s + | i == 0 = 0 + | otherwise = 1 - min r (min g b) / i + !i = (r + g + b) / 3 + !x = (2 * r - g - b) / 2.449489742783178 + !y = (g - b) / 1.4142135623730951 +{-# INLINE rgb2hsi #-} diff --git a/src/Graphics/Color/Model/HSL.hs b/src/Graphics/Color/Model/HSL.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model/HSL.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Color.Model.HSL +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model.HSL + ( HSL + -- * Constructors for an HSL color model. + , pattern ColorHSL + , pattern ColorHSLA + , pattern ColorH360SL + , Color + , ColorModel(..) + , hc2rgb + , hsl2rgb + , rgb2hsl + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.HSV (hc2rgb) +import Graphics.Color.Model.Internal +import Graphics.Color.Model.RGB + +----------- +--- HSL --- +----------- + +-- | Hue, Saturation and Luminance (Lightness) color model. +data HSL + +-- | `HSL` color model +newtype instance Color HSL e = HSL (V3 e) + +-- | Constructor for @HSL@. +pattern ColorHSL :: e -> e -> e -> Color HSL e +pattern ColorHSL h s l = HSL (V3 h s l) +{-# COMPLETE ColorHSL #-} + + +-- | Constructor for @HSL@ with alpha channel. +pattern ColorHSLA :: e -> e -> e -> e -> Color (Alpha HSL) e +pattern ColorHSLA h s l a = Alpha (ColorHSL h s l) a +{-# COMPLETE ColorHSLA #-} + +-- | Constructor for an HSL color model. Difference from `ColorHSL` is that channels are +-- restricted to `Double` and the hue is specified in 0 to 360 degree range, rather than 0 +-- to 1. Note, that this is not checked. +pattern ColorH360SL :: Double -> Double -> Double -> Color HSL Double +pattern ColorH360SL h s l <- ColorHSL ((* 360) -> h) s l where + ColorH360SL h s l = ColorHSL (h / 360) s l +{-# COMPLETE ColorH360SL #-} + +-- | `HSL` color model +deriving instance Eq e => Eq (Color HSL e) +-- | `HSL` color model +deriving instance Ord e => Ord (Color HSL e) +-- | `HSL` color model +deriving instance Functor (Color HSL) +-- | `HSL` color model +deriving instance Applicative (Color HSL) +-- | `HSL` color model +deriving instance Foldable (Color HSL) +-- | `HSL` color model +deriving instance Traversable (Color HSL) +-- | `HSL` color model +deriving instance Storable e => Storable (Color HSL e) + +-- | `HSL` color model +instance Elevator e => Show (Color HSL e) where + showsPrec _ = showsColorModel + +-- | `HSL` color model +instance Elevator e => ColorModel HSL e where + type Components HSL e = (e, e, e) + toComponents (ColorHSL h s l) = (h, s, l) + {-# INLINE toComponents #-} + fromComponents (h, s, l) = ColorHSL h s l + {-# INLINE fromComponents #-} + +hsl2rgb :: RealFrac e => Color HSL e -> Color RGB e +hsl2rgb (ColorHSL h s l) = (+ m) <$> hc2rgb h c + where + !c = (1 - abs (2 * l - 1)) * s + !m = l - c / 2 +{-# INLINE hsl2rgb #-} + + +rgb2hsl :: (Ord e, Floating e) => Color RGB e -> Color HSL e +rgb2hsl (ColorRGB r g b) = ColorHSL h s l + where + !max' = max r (max g b) + !min' = min r (min g b) + !h' | max' == r = ( (g - b) / (max' - min')) / 6 + | max' == g = (2 + (b - r) / (max' - min')) / 6 + | max' == b = (4 + (r - g) / (max' - min')) / 6 + | otherwise = 0 + !h + | h' < 0 = h' + 1 + | otherwise = h' + !s + | max' == 0 || min' == 1 = 0 + | otherwise = (max' - l) / min l (1 - l) + !l = (max' + min') / 2 +{-# INLINE rgb2hsl #-} diff --git a/src/Graphics/Color/Model/HSV.hs b/src/Graphics/Color/Model/HSV.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model/HSV.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Color.Model.HSV +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model.HSV + ( HSV + -- * Constructors for an HSV color model. + , pattern ColorHSV + , pattern ColorHSVA + , pattern ColorH360SV + , Color + , ColorModel(..) + , hc2rgb + , hsv2rgb + , rgb2hsv + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import Graphics.Color.Model.RGB + +----------- +--- HSV --- +----------- + +-- | Hue, Saturation and Value (Brightness) color model. +data HSV + +-- | `HSV` color model +newtype instance Color HSV e = HSV (V3 e) + +-- | Constructor for @HSV@. +pattern ColorHSV :: e -> e -> e -> Color HSV e +pattern ColorHSV h s v = HSV (V3 h s v) +{-# COMPLETE ColorHSV #-} + + +-- | Constructor for @HSV@ with alpha channel. +pattern ColorHSVA :: e -> e -> e -> e -> Color (Alpha HSV) e +pattern ColorHSVA h s v a = Alpha (ColorHSV h s v) a +{-# COMPLETE ColorHSVA #-} + +-- | Constructor for an HSV color model. Difference from `ColorHSV` is that channels are +-- restricted to `Double` and the hue is specified in 0 to 360 degree range, rather than 0 +-- to 1. Note, that this is not checked. +pattern ColorH360SV :: Double -> Double -> Double -> Color HSV Double +pattern ColorH360SV h s v <- ColorHSV ((* 360) -> h) s v where + ColorH360SV h s v = ColorHSV (h / 360) s v +{-# COMPLETE ColorH360SV #-} + +-- | `HSV` color model +deriving instance Eq e => Eq (Color HSV e) +-- | `HSV` color model +deriving instance Ord e => Ord (Color HSV e) +-- | `HSV` color model +deriving instance Functor (Color HSV) +-- | `HSV` color model +deriving instance Applicative (Color HSV) +-- | `HSV` color model +deriving instance Foldable (Color HSV) +-- | `HSV` color model +deriving instance Traversable (Color HSV) +-- | `HSV` color model +deriving instance Storable e => Storable (Color HSV e) + +-- | `HSV` color model +instance Elevator e => Show (Color HSV e) where + showsPrec _ = showsColorModel + +-- | `HSV` color model +instance Elevator e => ColorModel HSV e where + type Components HSV e = (e, e, e) + toComponents (ColorHSV h s v) = (h, s, v) + {-# INLINE toComponents #-} + fromComponents (h, s, v) = ColorHSV h s v + {-# INLINE fromComponents #-} + +hc2rgb :: RealFrac e => e -> e -> Color RGB e +hc2rgb h c + | h' < 0 = ColorRGB 0 0 0 + | h' <= 1 = ColorRGB c x 0 + | h' <= 2 = ColorRGB x c 0 + | h' <= 3 = ColorRGB 0 c x + | h' <= 4 = ColorRGB 0 x c + | h' <= 5 = ColorRGB x 0 c + | h' <= 6 = ColorRGB c 0 x + | otherwise = ColorRGB 0 0 0 + where + !h' = h * 6 + !hTrunc = truncate h' :: Int + !hMod2 = fromIntegral (hTrunc `mod` 2) + (h' - fromIntegral hTrunc) + !x = c * (1 - abs (hMod2 - 1)) +{-# INLINE hc2rgb #-} + +hsv2rgb :: RealFrac e => Color HSV e -> Color RGB e +hsv2rgb (ColorHSV h s v) = (+ m) <$> hc2rgb h c + where + !c = v * s + !m = v - c +{-# INLINE hsv2rgb #-} + + +rgb2hsv :: (Ord e, Fractional e) => Color RGB e -> Color HSV e +rgb2hsv (ColorRGB r g b) = ColorHSV h s v + where + !max' = max r (max g b) + !min' = min r (min g b) + !h' | max' == r = ( (g - b) / (max' - min')) / 6 + | max' == g = (2 + (b - r) / (max' - min')) / 6 + | max' == b = (4 + (r - g) / (max' - min')) / 6 + | otherwise = 0 + !h + | h' < 0 = h' + 1 + | otherwise = h' + !s + | max' == 0 = 0 + | otherwise = (max' - min') / max' + !v = max' +{-# INLINE rgb2hsv #-} diff --git a/src/Graphics/Color/Model/Internal.hs b/src/Graphics/Color/Model/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model/Internal.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Model.Internal +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model.Internal + ( Color + , ColorModel(..) + , module Graphics.Color.Algebra + , showsColorModel + , showsColorModelOpen + , foldr3 + , foldr4 + , traverse3 + , traverse4 + , sizeOfN + , alignmentN + , peek3 + , poke3 + , peek4 + , poke4 + , VU.MVector(MV_Color) + , VU.Vector(V_Color) + ) where + +import Control.Applicative +import Control.DeepSeq (NFData(rnf), deepseq) +import Control.Monad (liftM) +import Data.Default.Class (Default(..)) +import Data.Foldable +import Data.Typeable +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as VM +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU +import Foreign.Ptr +import Foreign.Storable +import Graphics.Color.Algebra +import Data.Kind + +-- | A Color family with a color space and a precision of elements. +data family Color cs e :: Type + +class ( Functor (Color cs) + , Applicative (Color cs) + , Foldable (Color cs) + , Traversable (Color cs) + , Eq (Color cs e) + , Show (Color cs e) + , VU.Unbox (Components cs e) + , VS.Storable (Color cs e) + , Typeable cs + , Elevator e + ) => + ColorModel cs e where + type Components cs e :: Type + -- | Convert a Color to a representation suitable for storage as an unboxed + -- element, usually a tuple of channels. + toComponents :: Color cs e -> Components cs e + -- | Convert from an elemnt representation back to a Color. + fromComponents :: Components cs e -> Color cs e + + -- | Display the @cs@ portion of the pixel. Color itself will not be evaluated. + -- + -- @since 0.1.0 + showsColorModelName :: Proxy (Color cs e) -> ShowS + showsColorModelName _ = showsType (Proxy :: Proxy cs) + + +instance ColorModel cs e => Default (Color cs e) where + def = pure 0 + {-# INLINE def #-} + + +instance ColorModel cs e => Num (Color cs e) where + (+) = liftA2 (+) + {-# INLINE (+) #-} + (-) = liftA2 (-) + {-# INLINE (-) #-} + (*) = liftA2 (*) + {-# INLINE (*) #-} + abs = fmap abs + {-# INLINE abs #-} + signum = fmap signum + {-# INLINE signum #-} + fromInteger = pure . fromInteger + {-# INLINE fromInteger #-} + + +instance (ColorModel cs e, Fractional e) => Fractional (Color cs e) where + (/) = liftA2 (/) + {-# INLINE (/) #-} + recip = fmap recip + {-# INLINE recip #-} + fromRational = pure . fromRational + {-# INLINE fromRational #-} + + +instance (ColorModel cs e, Floating e) => Floating (Color cs e) where + pi = pure pi + {-# INLINE pi #-} + exp = fmap exp + {-# INLINE exp #-} + log = fmap log + {-# INLINE log #-} + sin = fmap sin + {-# INLINE sin #-} + cos = fmap cos + {-# INLINE cos #-} + asin = fmap asin + {-# INLINE asin #-} + atan = fmap atan + {-# INLINE atan #-} + acos = fmap acos + {-# INLINE acos #-} + sinh = fmap sinh + {-# INLINE sinh #-} + cosh = fmap cosh + {-# INLINE cosh #-} + asinh = fmap asinh + {-# INLINE asinh #-} + atanh = fmap atanh + {-# INLINE atanh #-} + acosh = fmap acosh + {-# INLINE acosh #-} + +instance ColorModel cs e => Bounded (Color cs e) where + maxBound = pure maxValue + {-# INLINE maxBound #-} + minBound = pure minValue + {-# INLINE minBound #-} + +instance (ColorModel cs e, NFData e) => NFData (Color cs e) where + rnf = foldr' deepseq () + {-# INLINE rnf #-} + + +-- | Unboxing of a `Color`. +instance ColorModel cs e => VU.Unbox (Color cs e) + +newtype instance VU.MVector s (Color cs e) = MV_Color (VU.MVector s (Components cs e)) + +instance ColorModel cs e => VM.MVector VU.MVector (Color cs e) where + basicLength (MV_Color mvec) = VM.basicLength mvec + {-# INLINE basicLength #-} + basicUnsafeSlice idx len (MV_Color mvec) = MV_Color (VM.basicUnsafeSlice idx len mvec) + {-# INLINE basicUnsafeSlice #-} + basicOverlaps (MV_Color mvec) (MV_Color mvec') = VM.basicOverlaps mvec mvec' + {-# INLINE basicOverlaps #-} + basicUnsafeNew len = MV_Color `liftM` VM.basicUnsafeNew len + {-# INLINE basicUnsafeNew #-} + basicUnsafeReplicate len val = MV_Color `liftM` VM.basicUnsafeReplicate len (toComponents val) + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeRead (MV_Color mvec) idx = fromComponents `liftM` VM.basicUnsafeRead mvec idx + {-# INLINE basicUnsafeRead #-} + basicUnsafeWrite (MV_Color mvec) idx val = VM.basicUnsafeWrite mvec idx (toComponents val) + {-# INLINE basicUnsafeWrite #-} + basicClear (MV_Color mvec) = VM.basicClear mvec + {-# INLINE basicClear #-} + basicSet (MV_Color mvec) val = VM.basicSet mvec (toComponents val) + {-# INLINE basicSet #-} + basicUnsafeCopy (MV_Color mvec) (MV_Color mvec') = VM.basicUnsafeCopy mvec mvec' + {-# INLINE basicUnsafeCopy #-} + basicUnsafeMove (MV_Color mvec) (MV_Color mvec') = VM.basicUnsafeMove mvec mvec' + {-# INLINE basicUnsafeMove #-} + basicUnsafeGrow (MV_Color mvec) len = MV_Color `liftM` VM.basicUnsafeGrow mvec len + {-# INLINE basicUnsafeGrow #-} +#if MIN_VERSION_vector(0,11,0) + basicInitialize (MV_Color mvec) = VM.basicInitialize mvec + {-# INLINE basicInitialize #-} +#endif + + +newtype instance VU.Vector (Color cs e) = V_Color (VU.Vector (Components cs e)) + +instance (ColorModel cs e) => V.Vector VU.Vector (Color cs e) where + basicUnsafeFreeze (MV_Color mvec) = V_Color `liftM` V.basicUnsafeFreeze mvec + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeThaw (V_Color vec) = MV_Color `liftM` V.basicUnsafeThaw vec + {-# INLINE basicUnsafeThaw #-} + basicLength (V_Color vec) = V.basicLength vec + {-# INLINE basicLength #-} + basicUnsafeSlice idx len (V_Color vec) = V_Color (V.basicUnsafeSlice idx len vec) + {-# INLINE basicUnsafeSlice #-} + basicUnsafeIndexM (V_Color vec) idx = fromComponents `liftM` V.basicUnsafeIndexM vec idx + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeCopy (MV_Color mvec) (V_Color vec) = V.basicUnsafeCopy mvec vec + {-# INLINE basicUnsafeCopy #-} + elemseq (V_Color vec) val = V.elemseq vec (toComponents val) + {-# INLINE elemseq #-} + +channelSeparator :: Char +channelSeparator = ',' + +showsColorModel :: ColorModel cs e => Color cs e -> ShowS +showsColorModel px = ('<' :) . showsColorModelOpen px . ('>' :) + +showsColorModelOpen :: ColorModel cs e => Color cs e -> ShowS +showsColorModelOpen px = t . (":(" ++) . channels . (')' :) + where + t = asProxy px showsColorModelName + channels = + case toList px of + [] -> id + (x:xs) -> foldl' (\facc y -> facc . (channelSeparator :) . toShowS y) (toShowS x) xs + +-- TODO: consolidate those helpers inot algebra by means of: V2, V3, V4 and V5. +-- Foldable helpers. + +foldr3 :: (e -> a -> a) -> a -> e -> e -> e -> a +foldr3 f acc c0 c1 c2 = f c0 (f c1 (f c2 acc)) +{-# INLINE foldr3 #-} + +foldr4 :: (e -> a -> a) -> a -> e -> e -> e -> e -> a +foldr4 f acc c0 c1 c2 c3 = f c0 (f c1 (f c2 (f c3 acc))) +{-# INLINE foldr4 #-} + +traverse3 :: Applicative f => (a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> f b +traverse3 g f c0 c1 c2 = g <$> f c0 <*> f c1 <*> f c2 +{-# INLINE traverse3 #-} + +traverse4 :: Applicative f => (a -> a -> a -> a -> b) -> (t -> f a) -> t -> t -> t -> t -> f b +traverse4 g f c0 c1 c2 c3 = g <$> f c0 <*> f c1 <*> f c2 <*> f c3 +{-# INLINE traverse4 #-} + +-- Storable helpers + +sizeOfN :: forall cs e . Storable e => Int -> Color cs e -> Int +sizeOfN n _ = n * sizeOf (undefined :: e) +{-# INLINE sizeOfN #-} + +alignmentN :: forall cs e . Storable e => Int -> Color cs e -> Int +alignmentN _ _ = alignment (undefined :: e) +{-# INLINE alignmentN #-} + +peek3 :: Storable e => (e -> e -> e -> Color cs e) -> Ptr (Color cs e) -> IO (Color cs e) +peek3 f p = do + let q = castPtr p + c0 <- peek q + c1 <- peekElemOff q 1 + c2 <- peekElemOff q 2 + return $! f c0 c1 c2 +{-# INLINE peek3 #-} + +poke3 :: Storable e => Ptr (Color cs e) -> e -> e -> e -> IO () +poke3 p c0 c1 c2 = do + let q = castPtr p + poke q c0 + pokeElemOff q 1 c1 + pokeElemOff q 2 c2 +{-# INLINE poke3 #-} + +peek4 :: + forall cs e. Storable e + => (e -> e -> e -> e -> Color cs e) + -> Ptr (Color cs e) + -> IO (Color cs e) +peek4 f p = do + c0 <- peek (castPtr p) + peek3 (f c0) (p `plusPtr` sizeOf (undefined :: e)) +{-# INLINE peek4 #-} + +poke4 :: forall cs e . Storable e => Ptr (Color cs e) -> e -> e -> e -> e -> IO () +poke4 p c0 c1 c2 c3 = do + poke (castPtr p) c0 + poke3 (p `plusPtr` sizeOf (undefined :: e)) c1 c2 c3 +{-# INLINE poke4 #-} diff --git a/src/Graphics/Color/Model/RGB.hs b/src/Graphics/Color/Model/RGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model/RGB.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Model.RGB +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model.RGB + ( RGB + -- * Constructors for an RGB color model. + , pattern ColorRGB + , pattern ColorRGBA + , pattern RGB + , Color + , ColorModel(..) + ) where + +import Foreign.Storable +import Graphics.Color.Algebra +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal + +-- | The most common @RGB@ color model +data RGB + + +-- | `RGB` color model +newtype instance Color RGB e = RGB (V3 e) + +-- | Constructor for @RGB@ with alpha channel. +pattern ColorRGB :: e -> e -> e -> Color RGB e +pattern ColorRGB r g b = RGB (V3 r g b) +{-# COMPLETE ColorRGB #-} + +-- | Constructor for @RGB@ with alpha channel. +pattern ColorRGBA :: e -> e -> e -> e -> Color (Alpha RGB) e +pattern ColorRGBA r g b a = Alpha (RGB (V3 r g b)) a +{-# COMPLETE ColorRGBA #-} + +-- | `RGB` color model +deriving instance Eq e => Eq (Color RGB e) +-- | `RGB` color model +deriving instance Ord e => Ord (Color RGB e) +-- | `RGB` color model +instance Elevator e => Show (Color RGB e) where + showsPrec _ = showsColorModel + +-- | `RGB` color model +instance Elevator e => ColorModel RGB e where + type Components RGB e = (e, e, e) + toComponents (ColorRGB r g b) = (r, g, b) + {-# INLINE toComponents #-} + fromComponents (r, g, b) = ColorRGB r g b + {-# INLINE fromComponents #-} + +-- | `RGB` color model +deriving instance Functor (Color RGB) +-- | `RGB` color model +deriving instance Applicative (Color RGB) +-- | `RGB` color model +deriving instance Foldable (Color RGB) +-- | `RGB` color model +deriving instance Traversable (Color RGB) +-- | `RGB` color model +deriving instance Storable e => Storable (Color RGB e) diff --git a/src/Graphics/Color/Model/Y.hs b/src/Graphics/Color/Model/Y.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model/Y.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Model.Y +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model.Y + ( Y + -- * Constructors for Y color model. + , pattern ColorY + , pattern ColorYA + , Color(Y) + , Weights(..) + , rgb2y + ) where + +import Data.Coerce +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import Graphics.Color.Model.RGB + +------------- +--- Y --- +------------- + +-- | Luminance of a color +data Y + +-- | Luminance `Y` +newtype instance Color Y e = Y e + +-- | Constructor for @Y@ +pattern ColorY :: e -> Color Y e +pattern ColorY y = Y y +{-# COMPLETE ColorY #-} + +-- | Constructor for @Y@ with alpha channel. +pattern ColorYA :: e -> e -> Color (Alpha Y) e +pattern ColorYA y a = Alpha (Y y) a +{-# COMPLETE ColorYA #-} + +-- | `Y` color model +deriving instance Eq e => Eq (Color Y e) +-- | `Y` color model +deriving instance Ord e => Ord (Color Y e) +-- | `Y` color model +deriving instance Storable e => Storable (Color Y e) + + +-- | `Y` color model +instance Elevator e => Show (Color Y e) where + showsPrec _ = showsColorModel + +-- | `Y` color model +instance Elevator e => ColorModel Y e where + type Components Y e = e + toComponents (Y y) = y + {-# INLINE toComponents #-} + fromComponents = Y + {-# INLINE fromComponents #-} + +-- | `Y` color model +instance Functor (Color Y) where + fmap f (Y y) = Y (f y) + {-# INLINE fmap #-} + +-- | `Y` color model +instance Applicative (Color Y) where + pure = Y + {-# INLINE pure #-} + (Y fy) <*> (Y y) = Y (fy y) + {-# INLINE (<*>) #-} + +-- | `Y` color model +instance Foldable (Color Y) where + foldr f !z (Y y) = f y z + {-# INLINE foldr #-} + +-- | `Y` color model +instance Traversable (Color Y) where + traverse f (Y y) = Y <$> f y + {-# INLINE traverse #-} + + +rgb2y :: + forall e e'. (Elevator e', Elevator e, RealFloat e) + => Color RGB e' + -> Weights e + -> Color Y e +rgb2y rgb weights = + Y (coerce (fmap toRealFloat rgb :: Color RGB e) `dotProduct` coerce weights) +{-# INLINE rgb2y #-} + + +newtype Weights e = Weights + { unWeights :: V3 e + } diff --git a/src/Graphics/Color/Model/YCbCr.hs b/src/Graphics/Color/Model/YCbCr.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Model/YCbCr.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Graphics.Color.Model.YCbCr +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Model.YCbCr + ( pattern ColorYCbCr + , pattern ColorYCbCrA + , YCbCr + , Color(YCbCr) + , rgb2ycbcr + , ycbcr2rgb + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import Graphics.Color.Model.RGB +import Graphics.Color.Model.Y + +-- | `YCbCr` color model +data YCbCr + +-- | `YCbCr` color model +newtype instance Color YCbCr e = YCbCr (V3 e) + +-- | `YCbCr` color model +deriving instance Eq e => Eq (Color YCbCr e) +-- | `YCbCr` color model +deriving instance Ord e => Ord (Color YCbCr e) +-- | `YCbCr` color model +deriving instance Functor (Color YCbCr) +-- | `YCbCr` color model +deriving instance Applicative (Color YCbCr) +-- | `YCbCr` color model +deriving instance Foldable (Color YCbCr) +-- | `YCbCr` color model +deriving instance Traversable (Color YCbCr) +-- | `YCbCr` color model +deriving instance Storable e => Storable (Color YCbCr e) + +-- | `YCbCr` color model +instance Elevator e => Show (Color YCbCr e) where + showsPrec _ = showsColorModel + +-- | Constructor for an RGB color model in an alternative YCbCr color model +pattern ColorYCbCr :: e -> e -> e -> Color YCbCr e +pattern ColorYCbCr y cb cr = YCbCr (V3 y cb cr) +{-# COMPLETE ColorYCbCr #-} + +-- | Constructor for @YCbCr@ with alpha channel. +pattern ColorYCbCrA :: e -> e -> e -> e -> Color (Alpha YCbCr) e +pattern ColorYCbCrA y cb cr a = Alpha (YCbCr (V3 y cb cr)) a +{-# COMPLETE ColorYCbCrA #-} + + +-- | `YCbCr` color model +instance Elevator e => ColorModel YCbCr e where + type Components YCbCr e = (e, e, e) + toComponents (ColorYCbCr y cb cr) = (y, cb, cr) + {-# INLINE toComponents #-} + fromComponents (y, cb, cr) = ColorYCbCr y cb cr + {-# INLINE fromComponents #-} + showsColorModelName _ = ("YCbCr" ++) + + +rgb2ycbcr :: (Elevator e', Elevator e, RealFloat e) => Color RGB e' -> Weights e -> Color YCbCr e +rgb2ycbcr rgb' weights@(Weights (V3 kr _ kb)) = ColorYCbCr y cb cr + where + rgb@(ColorRGB r _ b) = toRealFloat <$> rgb' + ColorY y = rgb2y rgb weights + !cb = 0.5 + 0.5 * (b - y) / (1 - kb) + !cr = 0.5 + 0.5 * (r - y) / (1 - kr) +{-# INLINE rgb2ycbcr #-} + + +ycbcr2rgb :: (Elevator e', Elevator e, RealFloat e) => Color YCbCr e' -> Weights e -> Color RGB e +ycbcr2rgb ycbcr (Weights (V3 kr kg kb)) = ColorRGB r g b + where + ColorYCbCr y cb cr = toRealFloat <$> ycbcr + !r = y + (2 - 2 * kr) * cr + !b = y + (2 - 2 * kb) * cb + !g = (y - kr * r - kb * b) / kg +{-# INLINE ycbcr2rgb #-} diff --git a/src/Graphics/Color/Space.hs b/src/Graphics/Color/Space.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space.hs @@ -0,0 +1,16 @@ +-- | +-- Module : Graphics.Color.Space +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space + ( module X + ) where + +import Graphics.Color.Model.Alpha as X +import Graphics.Color.Model.Internal as X +import Graphics.Color.Space.Internal as X +import Graphics.Color.Space.RGB.Internal as X diff --git a/src/Graphics/Color/Space/CIE1931/XYZ.hs b/src/Graphics/Color/Space/CIE1931/XYZ.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/CIE1931/XYZ.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PatternSynonyms #-} +-- | +-- Module : Graphics.Color.Space.CIE1931.XYZ +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.CIE1931.XYZ + ( pattern ColorXYZ + , XYZ + ) where + +import Graphics.Color.Space.Internal diff --git a/src/Graphics/Color/Space/CIE1976/LAB.hs b/src/Graphics/Color/Space/CIE1976/LAB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/CIE1976/LAB.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.CIE1976.LAB +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.CIE1976.LAB + ( -- * Constructors for an CIE L*a*b* color space. + pattern LAB + , pattern ColorLAB + , pattern ColorLABA + , LAB + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import Graphics.Color.Space.Internal + +-------------- +--- CIELAB --- +-------------- + +-- | [CIE L*a*b*](https://en.wikipedia.org/wiki/CIELAB_color_space) color space +data LAB (i :: k) + +-- | Color in CIE L*a*b* color space +newtype instance Color (LAB i) e = LAB (V3 e) + + +pattern ColorLAB :: e -> e -> e -> Color (LAB i) e +pattern ColorLAB l' a' b' = LAB (V3 l' a' b') +{-# COMPLETE ColorLAB #-} + +-- | Constructor for @LAB@ with alpha channel. +pattern ColorLABA :: e -> e -> e -> e -> Color (Alpha (LAB i)) e +pattern ColorLABA l' a' b' a = Alpha (LAB (V3 l' a' b')) a +{-# COMPLETE ColorLABA #-} + +-- | CIE1976 `LAB` color space +deriving instance Eq e => Eq (Color (LAB i) e) + +-- | CIE1976 `LAB` color space +deriving instance Ord e => Ord (Color (LAB i) e) + +-- | CIE1976 `LAB` color space +deriving instance Functor (Color (LAB i)) + +-- | CIE1976 `LAB` color space +deriving instance Applicative (Color (LAB i)) + +-- | CIE1976 `LAB` color space +deriving instance Foldable (Color (LAB i)) + +-- | CIE1976 `LAB` color space +deriving instance Traversable (Color (LAB i)) + +-- | CIE1976 `LAB` color space +deriving instance Storable e => Storable (Color (LAB i) e) + +-- | CIE1976 `LAB` color space +instance (Illuminant i, Elevator e) => Show (Color (LAB i) e) where + showsPrec _ = showsColorModel + +-- | CIE1976 `LAB` color space +instance (Illuminant i, Elevator e) => ColorModel (LAB i) e where + type Components (LAB i) e = (e, e, e) + toComponents (ColorLAB l' a' b') = (l', a', b') + {-# INLINE toComponents #-} + fromComponents (l', a', b') = ColorLAB l' a' b' + {-# INLINE fromComponents #-} + +instance (Illuminant i, Elevator e, RealFloat e) => ColorSpace (LAB (i :: k)) i e where + type BaseModel (LAB i) = LAB i + type BaseSpace (LAB i) = LAB i + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance (ColorLAB l' _ _) = Y (ift (scaleLightness l')) + {-# INLINE luminance #-} + toColorXYZ = lab2xyz + {-# INLINE toColorXYZ #-} + fromColorXYZ = xyz2lab + {-# INLINE fromColorXYZ #-} + +lab2xyz :: + forall i a e. (Illuminant i, Elevator e, Elevator a, RealFloat a) + => Color (LAB i) e + -> Color (XYZ i) a +lab2xyz (ColorLAB l' a' b') = ColorXYZ x y z + where + !(ColorXYZ wx _ wz) = whitePointTristimulus :: Color (XYZ i) a + !l = scaleLightness l' + !x = wx * ift (l + toRealFloat a' / 500) + !y = ift l + !z = wz * ift (l - toRealFloat b' / 200) +{-# INLINE lab2xyz #-} + +scaleLightness :: (Elevator e, Elevator a, RealFloat a) => e -> a +scaleLightness l' = (toRealFloat l' + 16) / 116 +{-# INLINE scaleLightness #-} + +ift :: (Fractional a, Ord a) => a -> a +ift t + | t > 6 / 29 = t ^ (3 :: Int) + | otherwise = (108 / 841) * (t - 4 / 29) + + + +xyz2lab :: + forall i a e. (Illuminant i, Elevator a, Elevator e, RealFloat e) + => Color (XYZ i) a + -> Color (LAB i) e +xyz2lab (ColorXYZ x y z) = ColorLAB l' a' b' + where + !(ColorXYZ wx _ wz) = whitePointTristimulus :: Color (XYZ i) e + !fx = ft (toRealFloat x / wx) + !fy = ft (toRealFloat y) + !fz = ft (toRealFloat z / wz) + !l' = 116 * fy - 16 + !a' = 500 * (fx - fy) + !b' = 200 * (fy - fz) +{-# INLINE xyz2lab #-} + +ft :: RealFloat a => a -> a +ft t + | t > t0 = t ** (1 / 3) + | otherwise = t * m + 4 / 29 +{-# INLINE ft #-} + +m :: RealFloat a => a +m = 841 / 108 + +t0 :: RealFloat a => a +t0 = 216 / 24389 + -- where + -- m = 1/3 * δ^-2 = 841/108 =~ 7.787[037] + -- t0 = δ^3 =~ 0.008856 + -- δ = 6/29 =~ 0.2069 diff --git a/src/Graphics/Color/Space/Internal.hs b/src/Graphics/Color/Space/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/Internal.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Color.Space.Internal +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.Internal + ( Color(Luminance, XYZ, CIExyY) + , ColorSpace(..) + , Chromaticity(..) + , Primary(.., Primary) + , xPrimary + , yPrimary + , zPrimary + , primaryXZ + , primaryTristimulus + , Illuminant(..) + , WhitePoint(.., WhitePoint) + , Tristimulus(..) + , xWhitePoint + , yWhitePoint + , zWhitePoint + , whitePointXZ + , whitePointTristimulus + , CCT(..) + , Y + , pattern Y + , pattern YA + , XYZ + , pattern ColorXYZ + , pattern ColorXYZA + , CIExyY + , pattern ColorCIExy + , pattern ColorCIExyY + , module GHC.TypeNats + , module Graphics.Color.Algebra + , module Graphics.Color.Model.Internal + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import qualified Graphics.Color.Model.Y as CM +import Graphics.Color.Algebra +import Data.Typeable +import Data.Coerce +import GHC.TypeNats +import Data.Kind + +class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e, Typeable (Opaque cs)) => + ColorSpace cs (i :: k) e | cs -> i where + + type BaseModel cs :: Type + + type BaseSpace cs :: Type + type BaseSpace cs = cs + + -- | Drop color space down to the base color model + toBaseModel :: Color cs e -> Color (BaseModel cs) e + default toBaseModel :: + Coercible (Color cs e) (Color (BaseModel cs) e) => Color cs e -> Color (BaseModel cs) e + toBaseModel = coerce + + -- | Promote color model to a color space + fromBaseModel :: Color (BaseModel cs) e -> Color cs e + default fromBaseModel :: + Coercible (Color (BaseModel cs) e) (Color cs e) => Color (BaseModel cs) e -> Color cs e + fromBaseModel = coerce + + toBaseSpace :: ColorSpace (BaseSpace cs) i e => Color cs e -> Color (BaseSpace cs) e + fromBaseSpace :: ColorSpace (BaseSpace cs) i e => Color (BaseSpace cs) e -> Color cs e + + -- | Get the relative luminance of a color + -- + -- @since 0.1.0 + luminance :: (Elevator a, RealFloat a) => Color cs e -> Color (Y i) a + + toColorXYZ :: (Elevator a, RealFloat a) => Color cs e -> Color (XYZ i) a + default toColorXYZ :: + (ColorSpace (BaseSpace cs) i e, Elevator a, RealFloat a) => Color cs e -> Color (XYZ i) a + toColorXYZ = toColorXYZ . toBaseSpace + {-# INLINE toColorXYZ #-} + + fromColorXYZ :: (Elevator a, RealFloat a) => Color (XYZ i) a -> Color cs e + default fromColorXYZ :: + (ColorSpace (BaseSpace cs) i e, Elevator a, RealFloat a) => Color (XYZ i) a -> Color cs e + fromColorXYZ = fromBaseSpace . fromColorXYZ + {-# INLINE fromColorXYZ #-} + + +instance ( ColorSpace cs i e + , Opaque (Alpha cs) ~ cs + , Opaque (Alpha (BaseModel cs)) ~ BaseModel cs) => + ColorSpace (Alpha cs) i e where + type BaseModel (Alpha cs) = Alpha (BaseModel cs) + type BaseSpace (Alpha cs) = cs + + toBaseModel = modifyOpaque toBaseModel + {-# INLINE toBaseModel #-} + fromBaseModel = modifyOpaque fromBaseModel + {-# INLINE fromBaseModel #-} + luminance = luminance . dropAlpha + {-# INLINE luminance #-} + toBaseSpace = dropAlpha + {-# INLINE toBaseSpace #-} + fromBaseSpace c = Alpha c maxValue + {-# INLINE fromBaseSpace #-} + +-- | This is a data type that encodes a data point on the chromaticity diagram +newtype Chromaticity i e = + Chromaticity (Color (CIExyY i) e) + deriving (Eq, Show) + + +---------------- +-- WhitePoint -- +---------------- + +-- | Correlated color temperature (CCT) of a white point in Kelvin +newtype CCT (i :: k) = CCT + { unCCT :: Double + } deriving (Eq, Show) + +class (Typeable i, Typeable k, KnownNat (Temperature i)) => Illuminant (i :: k) where + type Temperature i :: n + whitePoint :: RealFloat e => WhitePoint i e + + colorTemperature :: CCT i + colorTemperature = CCT (fromIntegral (natVal (Proxy :: Proxy (Temperature i)))) + + +newtype WhitePoint (i :: k) e = WhitePointChromaticity (Chromaticity i e) + deriving (Eq) + +instance (Illuminant i, Elevator e) => Show (WhitePoint (i :: k) e) where + showsPrec n (WhitePointChromaticity wp) + | n == 0 = inner + | otherwise = ('(' :) . inner . (')' :) + where + inner = ("WhitePoint (" ++) . shows wp . (')' :) + +-- | Constructor for the most common @XYZ@ color space +pattern WhitePoint :: e -> e -> WhitePoint i e +pattern WhitePoint x y <- (coerce -> (V2 x y)) where + WhitePoint x y = coerce (V2 x y) +{-# COMPLETE WhitePoint #-} + + +newtype Tristimulus i e = Tristimulus (Color (XYZ i) e) + deriving (Show, Eq, Ord, Functor, Applicative) + +-- | @x@ value of a `WhitePoint` +-- +-- @since 0.1.0 +xWhitePoint :: WhitePoint i e -> e +xWhitePoint (coerce -> V2 x _) = x +{-# INLINE xWhitePoint #-} + +-- | @y@ value of a `WhitePoint` +-- +-- @since 0.1.0 +yWhitePoint :: WhitePoint i e -> e +yWhitePoint (coerce -> V2 _ y) = y +{-# INLINE yWhitePoint #-} + +-- | Compute @z@ value of a `WhitePoint`: @z = 1 - x - y@ +-- +-- @since 0.1.0 +zWhitePoint :: Num e => WhitePoint i e -> e +zWhitePoint wp = 1 - xWhitePoint wp - yWhitePoint wp +{-# INLINE zWhitePoint #-} + +-- | Compute a normalized @XYZ@ tristimulus of a white point, where @Y = 1@ +-- +-- @since 0.1.0 +whitePointTristimulus :: + forall i e. (Illuminant i, RealFloat e, Elevator e) + => Color (XYZ i) e +whitePointTristimulus = toColorXYZ (coerce (whitePoint :: WhitePoint i e) :: Color (CIExyY i) e) +{-# INLINE whitePointTristimulus #-} + + +-- | Compute @XYZ@ tristimulus of a white point. +-- +-- @since 0.1.0 +whitePointXZ :: + Fractional e + => e + -- ^ @Y@ value, which is usually set to @1@ + -> WhitePoint i e + -- ^ White point that specifies @x@ and @y@ + -> Color (XYZ i) e +whitePointXZ vY (coerce -> V2 x y) = ColorXYZ (vYy * x) vY (vYy * (1 - x - y)) + where !vYy = vY / y +{-# INLINE whitePointXZ #-} + +------------- +-- Primary -- +------------- + +newtype Primary (i :: k) e = PrimaryChromaticity (Chromaticity i e) + deriving (Eq, Show) + + +-- | Constructor for the most common @XYZ@ color space +pattern Primary :: e -> e -> Primary i e +pattern Primary x y <- (coerce -> V2 x y) where + Primary x y = coerce (V2 x y) +{-# COMPLETE Primary #-} + + + +xPrimary :: Primary i e -> e +xPrimary (coerce -> V2 x _) = x +{-# INLINE xPrimary #-} + +yPrimary :: Primary i e -> e +yPrimary (coerce -> V2 _ y) = y +{-# INLINE yPrimary #-} + +-- | Compute @z = 1 - x - y@ of a `Primary`. +zPrimary :: Num e => Primary i e -> e +zPrimary p = 1 - xPrimary p - yPrimary p +{-# INLINE zPrimary #-} + + + + +-- | Compute normalized `XYZ` tristimulus of a `Primary`, where @Y = 1@ +-- +-- @since 0.1.0 +primaryTristimulus :: + forall i e. (Illuminant i, RealFloat e, Elevator e) + => Primary i e + -- ^ Primary that specifies @x@ and @y@ + -> Color (XYZ i) e +primaryTristimulus xy = toColorXYZ (coerce xy :: Color (CIExyY i) e) +{-# INLINE primaryTristimulus #-} + +-- | Compute `XYZ` tristimulus of a `Primary`. +-- +-- @since 0.1.0 +primaryXZ :: + Fractional e => + e + -- ^ @Y@ value, which is usually set to @1@ + -> Primary i e + -- ^ Primary that specifies @x@ and @y@ + -> Color (XYZ i) e +primaryXZ vY (Primary x y) = ColorXYZ (vYy * x) vY (vYy * (1 - x - y)) + where !vYy = vY / y +{-# INLINE primaryXZ #-} + + +----------- +--- XYZ --- +----------- + +-- | The original color space CIE 1931 XYZ color space +data XYZ i + +-- | CIE1931 `XYZ` color space +newtype instance Color (XYZ i) e = XYZ (V3 e) + +-- | Constructor for the most common @XYZ@ color space +pattern ColorXYZ :: e -> e -> e -> Color (XYZ i) e +pattern ColorXYZ x y z = XYZ (V3 x y z) +{-# COMPLETE ColorXYZ #-} + +-- | Constructor for @XYZ@ with alpha channel. +pattern ColorXYZA :: e -> e -> e -> e -> Color (Alpha (XYZ i)) e +pattern ColorXYZA x y z a = Alpha (XYZ (V3 x y z)) a +{-# COMPLETE ColorXYZA #-} + + +-- | CIE1931 `XYZ` color space +deriving instance Eq e => Eq (Color (XYZ i) e) +-- | CIE1931 `XYZ` color space +deriving instance Ord e => Ord (Color (XYZ i) e) +-- | CIE1931 `XYZ` color space +deriving instance Functor (Color (XYZ i)) +-- | CIE1931 `XYZ` color space +deriving instance Applicative (Color (XYZ i)) +-- | CIE1931 `XYZ` color space +deriving instance Foldable (Color (XYZ i)) +-- | CIE1931 `XYZ` color space +deriving instance Traversable (Color (XYZ i)) +-- | CIE1931 `XYZ` color space +deriving instance Storable e => Storable (Color (XYZ i) e) + +-- | CIE1931 `XYZ` color space +instance (Illuminant i, Elevator e) => Show (Color (XYZ (i :: k)) e) where + showsPrec _ = showsColorModel + +-- | CIE1931 `XYZ` color space +instance (Illuminant i, Elevator e) => ColorModel (XYZ (i :: k)) e where + type Components (XYZ i) e = (e, e, e) + toComponents (ColorXYZ x y z) = (x, y, z) + {-# INLINE toComponents #-} + fromComponents (x, y, z) = ColorXYZ x y z + {-# INLINE fromComponents #-} + +-- | CIE1931 `XYZ` color space +instance (Illuminant i, Elevator e) => ColorSpace (XYZ i) i e where + type BaseModel (XYZ i) = XYZ i + toBaseModel = id + fromBaseModel = id + toBaseSpace = id + fromBaseSpace = id + luminance (ColorXYZ _ y _) = Y (toRealFloat y) + {-# INLINE luminance #-} + toColorXYZ (ColorXYZ x y z) = ColorXYZ (toRealFloat x) (toRealFloat y) (toRealFloat z) + {-# INLINE toColorXYZ #-} + fromColorXYZ (ColorXYZ x y z) = ColorXYZ (fromRealFloat x) (fromRealFloat y) (fromRealFloat z) + {-# INLINE fromColorXYZ #-} + +{-# RULES +"toColorXYZ :: Color (XYZ i) a -> Color (XYZ i) a" toColorXYZ = id +"fromColorXYZ :: Color (XYZ i) a -> Color (XYZ i) a" fromColorXYZ = id + #-} + + +--------------- +--- CIE xyY --- +--------------- + +-- | Alternative representation of the CIE 1931 XYZ color space +data CIExyY (i :: k) + +-- | CIE1931 `CIExyY` color space +newtype instance Color (CIExyY i) e = CIExyY (V2 e) + +-- | Constructor @CIE xyY@ color space. It only requires @x@ and @y@, then @Y@ part will +-- always be equal to 1. +pattern ColorCIExy :: e -> e -> Color (CIExyY i) e +pattern ColorCIExy x y = CIExyY (V2 x y) +{-# COMPLETE ColorCIExy #-} + +-- | Patttern match on the @CIE xyY@, 3rd argument @Y@ is always set to @1@ +pattern ColorCIExyY :: Num e => e -> e -> e -> Color (CIExyY i) e +pattern ColorCIExyY x y y' <- (addY -> V3 x y y') +{-# COMPLETE ColorCIExyY #-} + +addY :: Num e => Color (CIExyY i) e -> V3 e +addY (CIExyY (V2 x y)) = V3 x y 1 +{-# INLINE addY #-} + +-- | CIE xyY color space +deriving instance Eq e => Eq (Color (CIExyY i) e) +-- | CIE xyY color space +deriving instance Ord e => Ord (Color (CIExyY i) e) +-- | CIE xyY color space +deriving instance Functor (Color (CIExyY i)) +-- | CIE xyY color space +deriving instance Applicative (Color (CIExyY i)) +-- | CIE xyY color space +deriving instance Foldable (Color (CIExyY i)) +-- | CIE xyY color space +deriving instance Traversable (Color (CIExyY i)) +-- | CIE xyY color space +deriving instance Storable e => Storable (Color (CIExyY i) e) + +-- | CIE xyY color space +instance (Illuminant i, Elevator e) => Show (Color (CIExyY (i :: k)) e) where + showsPrec _ = showsColorModel + +-- | CIE xyY color space +instance (Illuminant i, Elevator e) => ColorModel (CIExyY (i :: k)) e where + type Components (CIExyY i) e = (e, e) + toComponents (CIExyY (V2 x y)) = (x, y) + {-# INLINE toComponents #-} + fromComponents (x, y) = CIExyY (V2 x y) + {-# INLINE fromComponents #-} + showsColorModelName _ = showsType (Proxy :: Proxy (CIExyY i)) + +-- | CIE xyY color space +instance (Illuminant i, Elevator e) => ColorSpace (CIExyY (i :: k)) i e where + type BaseModel (CIExyY i) = CIExyY i + toBaseModel = id + fromBaseModel = id + toBaseSpace = id + fromBaseSpace = id + luminance _ = Y 1 + {-# INLINE luminance #-} + toColorXYZ xy = ColorXYZ (x / y) 1 ((1 - x - y) / y) + where ColorCIExy x y = toRealFloat <$> xy + {-# INLINE toColorXYZ #-} + fromColorXYZ xyz = fromRealFloat <$> ColorCIExy (x / s) (y / s) + where + ColorXYZ x y z = xyz + !s = x + y + z + {-# INLINE fromColorXYZ #-} + + + +------------- +--- Y --- +------------- + +-- | [Relative Luminance](https://en.wikipedia.org/wiki/Relative_luminance) of a color +data Y (i :: k) + +-- | Luminance `Y` +newtype instance Color (Y i) e = Luminance (CM.Color CM.Y e) + +-- | Constructor for @Y@ with alpha channel. +pattern Y :: e -> Color (Y i) e +pattern Y y = Luminance (CM.Y y) +{-# COMPLETE Y #-} + +-- | Constructor for @Y@ with alpha channel. +pattern YA :: e -> e -> Color (Alpha (Y i)) e +pattern YA y a = Alpha (Luminance (CM.Y y)) a +{-# COMPLETE YA #-} + +-- | `Y` - relative luminance of a color space +deriving instance Eq e => Eq (Color (Y i) e) +-- | `Y` - relative luminance of a color space +deriving instance Ord e => Ord (Color (Y i) e) +-- | `Y` - relative luminance of a color space +deriving instance Functor (Color (Y i)) +-- | `Y` - relative luminance of a color space +deriving instance Applicative (Color (Y i)) +-- | `Y` - relative luminance of a color space +deriving instance Foldable (Color (Y i)) +-- | `Y` - relative luminance of a color space +deriving instance Traversable (Color (Y i)) +-- | `Y` - relative luminance of a color space +deriving instance Storable e => Storable (Color (Y i) e) + + +-- | `Y` - relative luminance of a color space +instance (Illuminant i, Elevator e) => Show (Color (Y i) e) where + showsPrec _ = showsColorModel + +-- | `Y` - relative luminance of a color space +instance (Illuminant i, Elevator e) => ColorModel (Y i) e where + type Components (Y i) e = e + toComponents = coerce + {-# INLINE toComponents #-} + fromComponents = coerce + {-# INLINE fromComponents #-} + + +-- | CIE1931 `XYZ` color space +instance (Illuminant i, Elevator e) => ColorSpace (Y i) i e where + type BaseModel (Y i) = CM.Y + toBaseSpace = id + fromBaseSpace = id + luminance = fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ (Y y) = ColorXYZ 0 (toRealFloat y) 0 + {-# INLINE toColorXYZ #-} + fromColorXYZ (ColorXYZ _ y _) = Y (fromRealFloat y) + {-# INLINE fromColorXYZ #-} + +{-# RULES +"luminance :: RealFloat a => Color Y a -> Color Y a" luminance = id + #-} diff --git a/src/Graphics/Color/Space/RGB.hs b/src/Graphics/Color/Space/RGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE PatternSynonyms #-} +-- | +-- Module : Graphics.Color.Space.RGB +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- + +module Graphics.Color.Space.RGB + ( -- * Default sRGB color space + pattern ColorSRGB + , pattern ColorSRGBA + , SRGB + , D65 + -- * Re-exports + , module Graphics.Color.Space + , module Graphics.Color.Space.RGB.Alternative + , module Graphics.Color.Space.RGB.Luma + ) where + +import Graphics.Color.Space +import Graphics.Color.Space.RGB.Alternative +import Graphics.Color.Space.RGB.Luma +import Graphics.Color.Space.RGB.SRGB (pattern ColorSRGB, pattern ColorSRGBA, SRGB, D65) diff --git a/src/Graphics/Color/Space/RGB/AdobeRGB.hs b/src/Graphics/Color/Space/RGB/AdobeRGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/AdobeRGB.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.RGB.AdobeRGB +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.AdobeRGB + ( -- * Constructors for a AdobeRGB color space. + pattern AdobeRGB + , pattern ColorAdobeRGB + , pattern ColorAdobeRGBA + , AdobeRGB + , D65 + , primaries + , npmStandard + , inpmStandard + , transfer + , itransfer + , module Graphics.Color.Space + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import qualified Graphics.Color.Model.RGB as CM +import Graphics.Color.Space +import Graphics.Color.Space.RGB.ITU.Rec601 (D65) + + +-- | A very common [AdobeRGB (1998)](https://en.wikipedia.org/wiki/Adobe_RGB_color_space) +-- color space with the default `D65` illuminant +-- +-- @since 0.1.0 +data AdobeRGB + +newtype instance Color AdobeRGB 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 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 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) + +-- | Adobe`RGB` color space +instance Elevator e => Show (Color AdobeRGB e) where + showsPrec _ = showsColorModel + +-- | Adobe`RGB` color space +instance Elevator e => ColorModel AdobeRGB e where + type Components AdobeRGB 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 + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgb2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgb + {-# INLINE fromColorXYZ #-} + + +-- | Adobe`RGB` color space +instance RedGreenBlue AdobeRGB D65 where + gamut = primaries + npm = npmStandard + inpm = inpmStandard + ecctf = fmap transfer + {-# INLINE ecctf #-} + dcctf = fmap itransfer + {-# INLINE dcctf #-} + +-- | sRGB 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 ] ] +-- +-- @since 0.1.0 +npmStandard :: RealFloat e => NPM AdobeRGB e +npmStandard = NPM $ M3x3 (V3 0.57667 0.18556 0.18823) + (V3 0.29734 0.62736 0.07529) + (V3 0.02703 0.07069 0.99134) + + +-- | sRGB 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 ] ] +-- +-- @since 0.1.0 +inpmStandard :: RealFloat e => INPM AdobeRGB e +inpmStandard = INPM $ M3x3 (V3 2.04159 -0.56501 -0.34473) + (V3 -0.96924 1.87597 0.04156) + (V3 0.01344 -0.11836 1.01517) + + + +-- | AdobeRGB transfer function "gamma": +-- +-- \[ +-- \gamma(u) = u^{2.19921875} = u^\frac{563}{256} +-- \] +-- +-- @since 0.1.0 +transfer :: Floating a => a -> a +transfer u = u ** (256 / 563) +{-# INLINE transfer #-} + + +-- | AdobeRGB inverse transfer function "gamma": +-- +-- \[ +-- \gamma^{-1}(u) = u^\frac{1}{2.19921875} = u^\frac{256}{563} +-- \] +-- +-- @since 0.1.0 +itransfer :: Floating a => a -> a +itransfer u = u ** 2.19921875 -- in rational form 563/256 +{-# INLINE itransfer #-} + +-- | @sRGB@ primaries +-- +-- @since 0.1.0 +primaries :: RealFloat e => Gamut rgb i e +primaries = Gamut (Primary 0.64 0.33) + (Primary 0.21 0.71) + (Primary 0.15 0.06) diff --git a/src/Graphics/Color/Space/RGB/Alternative.hs b/src/Graphics/Color/Space/RGB/Alternative.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Alternative.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE PatternSynonyms #-} +-- | +-- Module : Graphics.Color.Space.RGB.Alternative +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- + +module Graphics.Color.Space.RGB.Alternative + ( module X + ) where + +import Graphics.Color.Space.RGB.Alternative.HSI as X +import Graphics.Color.Space.RGB.Alternative.HSL as X +import Graphics.Color.Space.RGB.Alternative.HSV as X +import Graphics.Color.Space.RGB.Alternative.CMYK as X +import Graphics.Color.Space.RGB.Alternative.YCbCr as X diff --git a/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs b/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Alternative/CMYK.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Graphics.Color.Space.RGB.Alternative.CMYK +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Alternative.CMYK + ( pattern ColorCMYK + , pattern ColorCMYKA + , CMYK + , Color(CMYK) + , module Graphics.Color.Space + ) where + +import Data.Coerce +import Data.Proxy +import Data.Typeable +import Foreign.Storable +import Graphics.Color.Model.Alpha +import qualified Graphics.Color.Model.CMYK as CM +import Graphics.Color.Model.Internal +import Graphics.Color.Space + +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +data CMYK cs + +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +newtype instance Color (CMYK cs) e = CMYK (Color CM.CMYK e) + +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Eq e => Eq (Color (CMYK cs) e) +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Ord e => Ord (Color (CMYK cs) e) +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Functor (Color (CMYK cs)) +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Applicative (Color (CMYK cs)) +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Foldable (Color (CMYK cs)) +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Traversable (Color (CMYK cs)) +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Storable e => Storable (Color (CMYK cs) e) + +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +instance ColorModel cs e => Show (Color (CMYK cs) e) where + showsPrec _ = showsColorModel + +-- | Constructor for an RGB color space in an alternative CMYK color model +pattern ColorCMYK :: e -> e -> e -> e -> Color (CMYK cs) e +pattern ColorCMYK c m y k = CMYK (CM.ColorCMYK c m y k) +{-# COMPLETE ColorCMYK #-} + +-- | Constructor for @CMYK@ with alpha channel. +pattern ColorCMYKA :: e -> e -> e -> e -> e -> Color (Alpha (CMYK cs)) e +pattern ColorCMYKA c m y k a = Alpha (CMYK (CM.ColorCMYK c m y k)) a +{-# COMPLETE ColorCMYKA #-} + +-- | `CMYK` representation for some (@`RedGreenBlue` cs i@) color space +instance ColorModel cs e => ColorModel (CMYK cs) e where + type Components (CMYK cs) e = (e, e, e, e) + toComponents = toComponents . coerce + {-# INLINE toComponents #-} + fromComponents = coerce . fromComponents + {-# INLINE fromComponents #-} + showsColorModelName _ = ("CMYK-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) + + +-- | `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 + 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 #-} diff --git a/src/Graphics/Color/Space/RGB/Alternative/HSI.hs b/src/Graphics/Color/Space/RGB/Alternative/HSI.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Alternative/HSI.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Color.Space.RGB.Alternative.HSI +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Alternative.HSI + ( pattern ColorHSI + , pattern ColorHSIA + , pattern ColorH360SI + , HSI + , Color(HSI) + , module Graphics.Color.Space + ) where + +import Data.Coerce +import Data.Proxy +import Data.Typeable +import Foreign.Storable +import Graphics.Color.Model.Alpha +import qualified Graphics.Color.Model.HSI as CM +import Graphics.Color.Model.Internal +import Graphics.Color.Space + + +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +data HSI cs + +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +newtype instance Color (HSI cs) e = HSI (Color CM.HSI e) + +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Eq e => Eq (Color (HSI cs) e) +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Ord e => Ord (Color (HSI cs) e) +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Functor (Color (HSI cs)) +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Applicative (Color (HSI cs)) +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Foldable (Color (HSI cs)) +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Traversable (Color (HSI cs)) +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Storable e => Storable (Color (HSI cs) e) + +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +instance ColorModel cs e => Show (Color (HSI cs) e) where + showsPrec _ = showsColorModel + +-- | Constructor for an RGB color space in an alternative HSI color model +pattern ColorHSI :: e -> e -> e -> Color (HSI cs) e +pattern ColorHSI h s i = HSI (CM.ColorHSI h s i) +{-# COMPLETE ColorHSI #-} + +-- | Constructor for @HSI@ with alpha channel. +pattern ColorHSIA :: e -> e -> e -> e -> Color (Alpha (HSI cs)) e +pattern ColorHSIA h s i a = Alpha (HSI (CM.ColorHSI h s i)) a +{-# COMPLETE ColorHSIA #-} + + +-- | Constructor for an RGB color space in an alternative HSI color model. Difference from +-- `ColorHSI` is that the hue is specified in 0 to 360 degree range, rather than 0 to +-- 1. Note, that this is not checked. +pattern ColorH360SI :: RealFloat e => e -> e -> e -> Color (HSI cs) e +pattern ColorH360SI h s i <- ColorHSI ((* 360) -> h) s i where + ColorH360SI h s i = ColorHSI (h / 360) s i +{-# COMPLETE ColorH360SI #-} + +-- | `HSI` representation for some (@`RedGreenBlue` cs i@) color space +instance ColorModel cs e => ColorModel (HSI cs) e where + type Components (HSI cs) e = (e, e, e) + toComponents = toComponents . coerce + {-# INLINE toComponents #-} + fromComponents = coerce . fromComponents + {-# INLINE fromComponents #-} + showsColorModelName _ = ("HSI-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) + + +-- | `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 + toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsi2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsi . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} diff --git a/src/Graphics/Color/Space/RGB/Alternative/HSL.hs b/src/Graphics/Color/Space/RGB/Alternative/HSL.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Alternative/HSL.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Color.Space.RGB.Alternative.HSL +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Alternative.HSL + ( pattern ColorHSL + , pattern ColorHSLA + , pattern ColorH360SL + , HSL + , Color(HSL) + , module Graphics.Color.Space + ) where + +import Data.Coerce +import Data.Proxy +import Data.Typeable +import Foreign.Storable +import Graphics.Color.Model.Alpha +import qualified Graphics.Color.Model.HSL as CM +import Graphics.Color.Model.Internal +import Graphics.Color.Space + +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +data HSL cs + +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +newtype instance Color (HSL cs) e = HSL (Color CM.HSL e) + +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Eq e => Eq (Color (HSL cs) e) +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Ord e => Ord (Color (HSL cs) e) +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Functor (Color (HSL cs)) +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Applicative (Color (HSL cs)) +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Foldable (Color (HSL cs)) +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Traversable (Color (HSL cs)) +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Storable e => Storable (Color (HSL cs) e) + +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +instance ColorModel cs e => Show (Color (HSL cs) e) where + showsPrec _ = showsColorModel + +-- | Constructor for an RGB color space in an alternative HSL color model +pattern ColorHSL :: e -> e -> e -> Color (HSL cs) e +pattern ColorHSL h s i = HSL (CM.ColorHSL h s i) +{-# COMPLETE ColorHSL #-} + +-- | Constructor for @HSL@ with alpha channel. +pattern ColorHSLA :: e -> e -> e -> e -> Color (Alpha (HSL cs)) e +pattern ColorHSLA h s i a = Alpha (HSL (CM.ColorHSL h s i)) a +{-# COMPLETE ColorHSLA #-} + + +-- | Constructor for an RGB color space in an alternative HSL color model. Difference from +-- `ColorHSL` is that the hue is specified in 0 to 360 degree range, rather than 0 to +-- 1. Note, that this is not checked. +pattern ColorH360SL :: RealFloat e => e -> e -> e -> Color (HSL cs) e +pattern ColorH360SL h s i <- ColorHSL ((* 360) -> h) s i where + ColorH360SL h s i = ColorHSL (h / 360) s i +{-# COMPLETE ColorH360SL #-} + +-- | `HSL` representation for some (@`RedGreenBlue` cs i@) color space +instance ColorModel cs e => ColorModel (HSL cs) e where + type Components (HSL cs) e = (e, e, e) + toComponents = toComponents . coerce + {-# INLINE toComponents #-} + fromComponents = coerce . fromComponents + {-# INLINE fromComponents #-} + showsColorModelName _ = ("HSL-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) + + +-- | `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 + toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsl2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsl . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} diff --git a/src/Graphics/Color/Space/RGB/Alternative/HSV.hs b/src/Graphics/Color/Space/RGB/Alternative/HSV.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Alternative/HSV.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Color.Space.RGB.Alternative.HSV +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Alternative.HSV + ( pattern ColorHSV + , pattern ColorHSVA + , pattern ColorH360SV + , HSV + , Color(HSV) + , module Graphics.Color.Space + ) where + +import Data.Coerce +import Data.Proxy +import Foreign.Storable +import Graphics.Color.Model.Alpha +import qualified Graphics.Color.Model.HSV as CM +import Graphics.Color.Model.Internal +import Graphics.Color.Space + +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +data HSV cs + +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +newtype instance Color (HSV cs) e = HSV (Color CM.HSV e) + +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Eq e => Eq (Color (HSV cs) e) +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Ord e => Ord (Color (HSV cs) e) +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Functor (Color (HSV cs)) +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Applicative (Color (HSV cs)) +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Foldable (Color (HSV cs)) +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Traversable (Color (HSV cs)) +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Storable e => Storable (Color (HSV cs) e) + +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +instance ColorModel cs e => Show (Color (HSV cs) e) where + showsPrec _ = showsColorModel + +-- | Constructor for an RGB color space in an alternative HSV color model +pattern ColorHSV :: e -> e -> e -> Color (HSV cs) e +pattern ColorHSV h s i = HSV (CM.ColorHSV h s i) +{-# COMPLETE ColorHSV #-} + +-- | Constructor for @HSV@ with alpha channel. +pattern ColorHSVA :: e -> e -> e -> e -> Color (Alpha (HSV cs)) e +pattern ColorHSVA h s i a = Alpha (HSV (CM.ColorHSV h s i)) a +{-# COMPLETE ColorHSVA #-} + + +-- | Constructor for an RGB color space in an alternative HSV color model. Difference from +-- `ColorHSV` is that the hue is specified in 0 to 360 degree range, rather than 0 to +-- 1. Note, that this is not checked. +pattern ColorH360SV :: RealFloat e => e -> e -> e -> Color (HSV cs) e +pattern ColorH360SV h s i <- ColorHSV ((* 360) -> h) s i where + ColorH360SV h s i = ColorHSV (h / 360) s i +{-# COMPLETE ColorH360SV #-} + +-- | `HSV` representation for some (@`RedGreenBlue` cs i@) color space +instance ColorModel cs e => ColorModel (HSV cs) e where + type Components (HSV cs) e = (e, e, e) + toComponents = toComponents . coerce + {-# INLINE toComponents #-} + fromComponents = coerce . fromComponents + {-# INLINE fromComponents #-} + showsColorModelName _ = ("HSV-" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) + + +-- | `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 + toBaseSpace = mkColorRGB . fmap fromDouble . CM.hsv2rgb . fmap toDouble . coerce + {-# INLINE toBaseSpace #-} + fromBaseSpace = coerce . fmap fromDouble . CM.rgb2hsv . fmap toDouble . unColorRGB + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} diff --git a/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs b/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Graphics.Color.Space.RGB.Alternative.YCbCr +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Alternative.YCbCr + ( pattern ColorYCbCr + , pattern ColorYCbCrA + , YCbCr + , Color(YCbCr) + , module Graphics.Color.Space + ) where + +import Data.Coerce +import Data.Proxy +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import qualified Graphics.Color.Model.YCbCr as CM +import Graphics.Color.Space +import Graphics.Color.Space.RGB.SRGB +import Graphics.Color.Space.RGB.Luma + +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +data YCbCr cs + +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +newtype instance Color (YCbCr cs) e = YCbCr (Color CM.YCbCr e) + +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Eq e => Eq (Color (YCbCr cs) e) +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Ord e => Ord (Color (YCbCr cs) e) +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Functor (Color (YCbCr cs)) +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Applicative (Color (YCbCr cs)) +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Foldable (Color (YCbCr cs)) +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Traversable (Color (YCbCr cs)) +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +deriving instance Storable e => Storable (Color (YCbCr cs) e) + +-- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space +instance ColorModel cs e => Show (Color (YCbCr cs) e) where + showsPrec _ = showsColorModel + +-- | Constructor for an RGB color space in an alternative YCbCr color model +pattern ColorYCbCr :: e -> e -> e -> Color (YCbCr cs) e +pattern ColorYCbCr y cb cr = YCbCr (CM.ColorYCbCr y cb cr) +{-# COMPLETE ColorYCbCr #-} + +-- | Constructor for @YCbCr@ with alpha channel. +pattern ColorYCbCrA :: e -> e -> e -> e -> Color (Alpha (YCbCr cs)) e +pattern ColorYCbCrA y cb cr a = Alpha (YCbCr (CM.ColorYCbCr y cb cr)) a +{-# COMPLETE ColorYCbCrA #-} + + +-- | `YCbCr` color model +instance ColorModel cs e => ColorModel (YCbCr cs) e where + type Components (YCbCr cs) e = (e, e, e) + toComponents (ColorYCbCr y cb cr) = (y, cb, cr) + {-# INLINE toComponents #-} + fromComponents (y, cb, cr) = ColorYCbCr y cb cr + {-# INLINE fromComponents #-} + 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 + toBaseSpace = fmap fromRealFloat . ycbcr2rgb . fmap toFloat + {-# INLINE toBaseSpace #-} + fromBaseSpace = fmap fromRealFloat . rgb2ycbcr . fmap toFloat + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# 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 + toBaseSpace = fmap fromDouble . fromColorYCbCr + {-# INLINE toBaseSpace #-} + fromBaseSpace = fmap fromDouble . toColorYCbCr + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + + +-- | Source: ITU-T Rec. T.871 +ycbcr2rgb :: (RedGreenBlue cs i, Ord e, Floating e) => Color (YCbCr cs) e -> Color cs e +ycbcr2rgb (ColorYCbCr y cb cr) = ColorRGB r g b + where + !cb05 = cb - 0.5 + !cr05 = cr - 0.5 + !r = clamp01 (y + 1.402 * cr05) + !g = clamp01 (y - 0.344136 * cb05 - 0.714136 * cr05) + !b = clamp01 (y + 1.772 * cb05) +{-# INLINE ycbcr2rgb #-} + +-- | Source: ITU-T Rec. T.871 +rgb2ycbcr :: (RedGreenBlue cs i, Floating e) => Color cs e -> Color (YCbCr cs) e +rgb2ycbcr (ColorRGB r g b) = ColorYCbCr y cb cr + where + !y = 0.299 * r + 0.587 * g + 0.114 * b + !cb = 0.5 - 0.168736 * r - 0.331264 * g + 0.5 * b + !cr = 0.5 + 0.5 * r - 0.418688 * g - 0.081312 * b +{-# INLINE rgb2ycbcr #-} + + +toColorYCbCr :: + forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e) + => Color cs e' + -> Color (YCbCr cs) e +toColorYCbCr rgb = YCbCr (CM.rgb2ycbcr (unColorRGB rgb) weights) + where + !weights = rgbLumaWeights rgb +{-# INLINE toColorYCbCr #-} + +fromColorYCbCr :: + forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e) + => Color (YCbCr cs) e' + -> Color cs e +fromColorYCbCr ycbcr = rgb + where + !rgb = mkColorRGB (CM.ycbcr2rgb (coerce ycbcr :: Color CM.YCbCr e') weights) + !weights = rgbLumaWeights rgb +{-# INLINE fromColorYCbCr #-} diff --git a/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs b/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.RGB.Derived.AdobeRGB +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Derived.AdobeRGB + ( AdobeRGB + , AdobeRGB.primaries + , AdobeRGB.transfer + , AdobeRGB.itransfer + , module Graphics.Color.Space + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import qualified Graphics.Color.Model.RGB as CM +import Graphics.Color.Space +import qualified Graphics.Color.Space.RGB.AdobeRGB as AdobeRGB + + +-- | The most common @AdobeRGB@ color space with an arbitrary illuminant +data AdobeRGB (i :: k) + +-- | `AdobeRGB` color space (derived) +newtype instance Color (AdobeRGB i) e = AdobeRGB (Color CM.RGB e) + +-- | `AdobeRGB` color space (derived) +deriving instance Eq e => Eq (Color (AdobeRGB i) e) +-- | `AdobeRGB` color space (derived) +deriving instance Ord e => Ord (Color (AdobeRGB i) e) +-- | `AdobeRGB` color space (derived) +deriving instance Functor (Color (AdobeRGB i)) +-- | `AdobeRGB` color space (derived) +deriving instance Applicative (Color (AdobeRGB i)) +-- | `AdobeRGB` color space (derived) +deriving instance Foldable (Color (AdobeRGB i)) +-- | `AdobeRGB` color space (derived) +deriving instance Traversable (Color (AdobeRGB i)) +-- | `AdobeRGB` color space (derived) +deriving instance Storable e => Storable (Color (AdobeRGB i) e) + +-- | `AdobeRGB` color space (derived) +instance (Illuminant i, Elevator e) => Show (Color (AdobeRGB (i :: k)) 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) + toComponents = toComponents . unColorRGB + {-# INLINE toComponents #-} + fromComponents = mkColorRGB . fromComponents + {-# INLINE fromComponents #-} + +-- | `AdobeRGB` color space (derived) +instance (Illuminant i, Elevator e) => ColorSpace (AdobeRGB i) i e where + type BaseModel (AdobeRGB i) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgb2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgb + {-# INLINE fromColorXYZ #-} + +-- | `AdobeRGB` color space (derived) +instance Illuminant i => RedGreenBlue (AdobeRGB i) i where + gamut = AdobeRGB.primaries + ecctf = fmap AdobeRGB.transfer + {-# INLINE ecctf #-} + dcctf = fmap AdobeRGB.itransfer + {-# INLINE dcctf #-} diff --git a/src/Graphics/Color/Space/RGB/Derived/SRGB.hs b/src/Graphics/Color/Space/RGB/Derived/SRGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Derived/SRGB.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.RGB.Derived.SRGB +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Derived.SRGB + ( SRGB + , SRGB.primaries + , SRGB.transfer + , SRGB.itransfer + , module Graphics.Color.Space + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import qualified Graphics.Color.Model.RGB as CM +import Graphics.Color.Space +import Graphics.Color.Space.RGB.Luma +import qualified Graphics.Color.Space.RGB.SRGB as SRGB + + +-- | The most common @sRGB@ color space with an arbitrary illuminant +data SRGB (i :: k) + +-- | `SRGB` color space (derived) +newtype instance Color (SRGB i) e = SRGB (Color CM.RGB e) + +-- | `SRGB` color space (derived) +deriving instance Eq e => Eq (Color (SRGB i) e) +-- | `SRGB` color space (derived) +deriving instance Ord e => Ord (Color (SRGB i) e) +-- | `SRGB` color space (derived) +deriving instance Functor (Color (SRGB i)) +-- | `SRGB` color space (derived) +deriving instance Applicative (Color (SRGB i)) +-- | `SRGB` color space (derived) +deriving instance Foldable (Color (SRGB i)) +-- | `SRGB` color space (derived) +deriving instance Traversable (Color (SRGB i)) +-- | `SRGB` color space (derived) +deriving instance Storable e => Storable (Color (SRGB i) e) + +-- | `SRGB` color space (derived) +instance (Illuminant i, Elevator e) => Show (Color (SRGB (i :: k)) 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) + toComponents = toComponents . unColorRGB + {-# INLINE toComponents #-} + fromComponents = mkColorRGB . fromComponents + {-# INLINE fromComponents #-} + +-- | `SRGB` color space (derived) +instance (Illuminant i, Elevator e) => ColorSpace (SRGB i) i e where + type BaseModel (SRGB i) = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgb2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgb + {-# INLINE fromColorXYZ #-} + +-- | `SRGB` color space (derived) +instance Illuminant i => RedGreenBlue (SRGB i) i where + gamut = SRGB.primaries + ecctf = fmap SRGB.transfer + {-# INLINE ecctf #-} + dcctf = fmap SRGB.itransfer + {-# INLINE dcctf #-} + + +instance Luma (SRGB i) where + rWeight = 0.299 + gWeight = 0.587 + bWeight = 0.114 diff --git a/src/Graphics/Color/Space/RGB/ITU/Rec470.hs b/src/Graphics/Color/Space/RGB/ITU/Rec470.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/ITU/Rec470.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.RGB.ITU.Rec470 +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.ITU.Rec470 + ( pattern BT470_525 + , BT470_525 + , C + , pattern BT470_625 + , BT470_625 + , D65 + , primaries525 + , primaries625 + , module Graphics.Color.Space + ) where + +import Foreign.Storable +import qualified Graphics.Color.Model.RGB as CM +import Graphics.Color.Space +import Graphics.Color.Illuminant.ITU.Rec470 + +------------------------------------ +-- ITU-R BT.470 (525) -------------- +------------------------------------ + +-- | [ITU-R BT.470](https://www.itu.int/rec/R-REC-BT.470) (525) color space. Used in NTSC +data BT470_525 + +newtype instance Color BT470_525 e = BT470_525 (Color CM.RGB e) + +-- | ITU-R BT.470 (525) color space +deriving instance Eq e => Eq (Color BT470_525 e) +-- | ITU-R BT.470 (525) color space +deriving instance Ord e => Ord (Color BT470_525 e) +-- | ITU-R BT.470 (525) color space +deriving instance Functor (Color BT470_525) +-- | ITU-R BT.470 (525) color space +deriving instance Applicative (Color BT470_525) +-- | ITU-R BT.470 (525) color space +deriving instance Foldable (Color BT470_525) +-- | ITU-R BT.470 (525) color space +deriving instance Traversable (Color BT470_525) +-- | ITU-R BT.470 (525) color space +deriving instance Storable e => Storable (Color BT470_525 e) + +-- | ITU-R BT.470 (525) color space +instance Elevator e => Show (Color BT470_525 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) + 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 + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgb2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgb + {-# INLINE fromColorXYZ #-} + +-- | ITU-R BT.470 (525) color space +instance RedGreenBlue BT470_525 C where + gamut = primaries525 + ecctf = fmap (gamma 2.2) + {-# INLINE ecctf #-} + dcctf = fmap (igamma 2.2) + {-# INLINE dcctf #-} + +------------------------------------ +-- ITU-R BT.470 (625) -------------- +------------------------------------ + +-- | [ITU-R BT.470](https://www.itu.int/rec/R-REC-BT.470) (625) color space. Used in PAL/SECAM +data BT470_625 + +newtype instance Color BT470_625 e = BT470_625 (Color CM.RGB e) + +-- | ITU-R BT.470 (625) color space +deriving instance Eq e => Eq (Color BT470_625 e) +-- | ITU-R BT.470 (625) color space +deriving instance Ord e => Ord (Color BT470_625 e) +-- | ITU-R BT.470 (625) color space +deriving instance Functor (Color BT470_625) +-- | ITU-R BT.470 (625) color space +deriving instance Applicative (Color BT470_625) +-- | ITU-R BT.470 (625) color space +deriving instance Foldable (Color BT470_625) +-- | ITU-R BT.470 (625) color space +deriving instance Traversable (Color BT470_625) +-- | ITU-R BT.470 (625) color space +deriving instance Storable e => Storable (Color BT470_625 e) + +-- | ITU-R BT.470 (625) color space +instance Elevator e => Show (Color BT470_625 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) + 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 + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgb2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgb + {-# INLINE fromColorXYZ #-} + +-- | ITU-R BT.470 (625) color space +instance RedGreenBlue BT470_625 D65 where + gamut = primaries625 + ecctf = fmap (gamma 2.8) + {-# INLINE ecctf #-} + dcctf = fmap (igamma 2.8) + {-# INLINE dcctf #-} + +gamma :: Floating a => a -> a -> a +gamma p v = v ** p +{-# INLINE gamma #-} + +igamma :: Floating a => a -> a -> a +igamma p v = v ** (1 / p) +{-# INLINE igamma #-} + +-- | Primaries for ITU-R BT.470 (525). +-- +-- @since 0.1.0 +primaries525 :: RealFloat e => Gamut rgb i e +primaries525 = Gamut (Primary 0.67 0.33) + (Primary 0.21 0.71) + (Primary 0.14 0.08) + + +-- | Primaries for ITU-R BT.470 and BT.601 (625). +-- +-- @since 0.1.0 +primaries625 :: RealFloat e => Gamut rgb i e +primaries625 = Gamut (Primary 0.64 0.33) + (Primary 0.29 0.60) + (Primary 0.15 0.06) + diff --git a/src/Graphics/Color/Space/RGB/ITU/Rec601.hs b/src/Graphics/Color/Space/RGB/ITU/Rec601.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/ITU/Rec601.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.RGB.ITU.Rec601 +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.ITU.Rec601 + ( pattern BT601_525 + , BT601_525 + , pattern BT601_625 + , BT601_625 + , D65 + , primaries525 + , primaries625 + , transfer + , itransfer + , module Graphics.Color.Space + ) where + +import Foreign.Storable +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 + + + +------------------------------------ +-- ITU-R BT.601 (525) -------------- +------------------------------------ + +-- | [ITU-R BT.601](https://en.wikipedia.org/wiki/Rec._601) (525) color space +data BT601_525 + +newtype instance Color BT601_525 e = BT601_525 (Color CM.RGB e) + +-- | ITU-R BT.601 (525) color space +deriving instance Eq e => Eq (Color BT601_525 e) +-- | ITU-R BT.601 (525) color space +deriving instance Ord e => Ord (Color BT601_525 e) +-- | ITU-R BT.601 (525) color space +deriving instance Functor (Color BT601_525) +-- | ITU-R BT.601 (525) color space +deriving instance Applicative (Color BT601_525) +-- | ITU-R BT.601 (525) color space +deriving instance Foldable (Color BT601_525) +-- | ITU-R BT.601 (525) color space +deriving instance Traversable (Color BT601_525) +-- | ITU-R BT.601 (525) color space +deriving instance Storable e => Storable (Color BT601_525 e) + +-- | ITU-R BT.601 (525) color space +instance Elevator e => Show (Color BT601_525 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) + 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 + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgb2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgb + {-# INLINE fromColorXYZ #-} + +-- | ITU-R BT.601 (525) color space +instance RedGreenBlue BT601_525 D65 where + gamut = primaries525 + ecctf = fmap transfer + {-# INLINE ecctf #-} + dcctf = fmap itransfer + {-# INLINE dcctf #-} + +------------------------------------ +-- ITU-R BT.601 (625) -------------- +------------------------------------ + +-- | [ITU-R BT.601](https://en.wikipedia.org/wiki/Rec._601) (625) color space +data BT601_625 + +newtype instance Color BT601_625 e = BT601_625 (Color CM.RGB e) + +-- | ITU-R BT.601 (625) color space +deriving instance Eq e => Eq (Color BT601_625 e) +-- | ITU-R BT.601 (625) color space +deriving instance Ord e => Ord (Color BT601_625 e) +-- | ITU-R BT.601 (625) color space +deriving instance Functor (Color BT601_625) +-- | ITU-R BT.601 (625) color space +deriving instance Applicative (Color BT601_625) +-- | ITU-R BT.601 (625) color space +deriving instance Foldable (Color BT601_625) +-- | ITU-R BT.601 (625) color space +deriving instance Traversable (Color BT601_625) +-- | ITU-R BT.601 (625) color space +deriving instance Storable e => Storable (Color BT601_625 e) + +-- | ITU-R BT.601 (625) color space +instance Elevator e => Show (Color BT601_625 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) + toComponents = toComponents . unColorRGB + {-# INLINE toComponents #-} + fromComponents = mkColorRGB . fromComponents + {-# INLINE fromComponents #-} + +-- | ITU-R BT.601 (625) color space +instance Elevator e => ColorSpace BT601_625 D65 e where + type BaseModel BT601_625 = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgb2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgb + {-# INLINE fromColorXYZ #-} + +-- | ITU-R BT.601 (625) color space +instance RedGreenBlue BT601_625 D65 where + gamut = primaries625 + ecctf = fmap transfer + {-# INLINE ecctf #-} + dcctf = fmap itransfer + {-# INLINE dcctf #-} + +instance Luma BT601_525 where + rWeight = 0.299 + gWeight = 0.587 + bWeight = 0.114 + +instance Luma BT601_625 where + rWeight = 0.299 + gWeight = 0.587 + bWeight = 0.114 + + +-- | Rec.601 transfer function "gamma". This is a helper function, therefore `ecctf` should be used +-- instead. +-- +-- \[ +-- \gamma(L) = \begin{cases} +-- 4.500 L & L \le 0.018 \\ +-- 1.099 L^{0.45} - 0.099 & \text{otherwise} +-- \end{cases} +-- \] +-- +-- @since 0.1.0 +transfer :: (Ord a, Floating a) => a -> a +transfer l + | l < 0.018 = 4.5 * l + | otherwise = 1.099 * (l ** 0.45 {- ~ 1 / 2.2 -}) - 0.099 +{-# INLINE transfer #-} + +-- | Rec.601 inverse transfer function "gamma". This is a helper function, therefore `dcctf` should +-- be used instead. +-- +-- \[ +-- \gamma^{-1}(E) = \begin{cases} +-- E / 4.5 & E \leq gamma(0.018) \\ +-- \left(\tfrac{E + 0.099}{1.099}\right)^{\frac{1}{0.45}} & \text{otherwise} +-- \end{cases} +-- \] +-- +-- @since 0.1.0 +itransfer :: (Ord a, Floating a) => a -> a +itransfer e + | e < inv0018 = e / 4.5 + | otherwise = ((e + 0.099) / 1.099) ** (1 / 0.45) + where + !inv0018 = transfer 0.018 -- ~ 0.081 +{-# INLINE itransfer #-} + + +-- | Primaries for ITU-R BT.601 (525). +-- +-- @since 0.1.0 +primaries525 :: RealFloat e => Gamut rgb i e +primaries525 = Gamut (Primary 0.630 0.340) + (Primary 0.310 0.595) + (Primary 0.155 0.070) + diff --git a/src/Graphics/Color/Space/RGB/ITU/Rec709.hs b/src/Graphics/Color/Space/RGB/ITU/Rec709.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/ITU/Rec709.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.RGB.ITU.Rec709 +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.ITU.Rec709 + ( pattern BT709 + , BT709 + , D65 + , primaries + , Rec601.transfer + , Rec601.itransfer + , module Graphics.Color.Space + ) where + +import Foreign.Storable +import Graphics.Color.Model.Internal +import qualified Graphics.Color.Model.RGB as CM +import Graphics.Color.Space +import Graphics.Color.Space.RGB.ITU.Rec601 as Rec601 (D65, itransfer, transfer) +import Graphics.Color.Space.RGB.Luma + +-- | [ITU-R BT.709](https://en.wikipedia.org/wiki/Rec._709) color space +data BT709 + +newtype instance Color BT709 e = BT709 (Color CM.RGB e) + +-- | ITU-R BT.709 color space +deriving instance Eq e => Eq (Color BT709 e) +-- | ITU-R BT.709 color space +deriving instance Ord e => Ord (Color BT709 e) +-- | ITU-R BT.709 color space +deriving instance Functor (Color BT709) +-- | ITU-R BT.709 color space +deriving instance Applicative (Color BT709) +-- | ITU-R BT.709 color space +deriving instance Foldable (Color BT709) +-- | ITU-R BT.709 color space +deriving instance Traversable (Color BT709) +-- | ITU-R BT.709 color space +deriving instance Storable e => Storable (Color BT709 e) + +-- | ITU-R BT.709 color space +instance Elevator e => Show (Color BT709 e) where + showsPrec _ = showsColorModel + +-- | ITU-R BT.709 color space +instance Elevator e => ColorModel BT709 e where + type Components BT709 e = (e, e, e) + toComponents = toComponents . unColorRGB + {-# INLINE toComponents #-} + fromComponents = mkColorRGB . fromComponents + {-# INLINE fromComponents #-} + +-- | ITU-R BT.709 color space +instance Elevator e => ColorSpace BT709 D65 e where + type BaseModel BT709 = CM.RGB + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgb2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgb + {-# INLINE fromColorXYZ #-} + +-- | ITU-R BT.709 color space +instance RedGreenBlue BT709 D65 where + gamut = primaries + ecctf = fmap Rec601.transfer + {-# INLINE ecctf #-} + dcctf = fmap Rec601.itransfer + {-# INLINE dcctf #-} + + +-- | Primaries for ITU-R BT.709, which are also the primaries for sRGB color space. +-- +-- @since 0.1.0 +primaries :: RealFloat e => Gamut rgb i e +primaries = Gamut (Primary 0.64 0.33) + (Primary 0.30 0.60) + (Primary 0.15 0.06) + + +instance Luma BT709 where + rWeight = 0.2126 + gWeight = 0.7152 + bWeight = 0.0722 diff --git a/src/Graphics/Color/Space/RGB/Internal.hs b/src/Graphics/Color/Space/RGB/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Internal.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Color.Space.RGB.Internal +-- Copyright : (c) Alexey Kuleshevich 2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Internal + ( RedGreenBlue(..) + , pattern ColorRGB + , pattern ColorRGBA + , Gamut(..) + , rgb2xyz + , xyz2rgb + , rgbLuminance + , NPM(..) + , npmApply + , npmDerive + , INPM(..) + , inpmApply + , inpmDerive + , rgbColorGamut + , pixelWhitePoint + , gamutWhitePoint + , module Graphics.Color.Algebra + ) where + +import Data.Coerce +import Graphics.Color.Algebra +import Graphics.Color.Model.Alpha +import qualified Graphics.Color.Model.RGB as CM +import Graphics.Color.Space.Internal + + +class Illuminant i => RedGreenBlue cs (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 + + -- | Decoding color component transfer function (forward) + dcctf :: (RealFloat a, Elevator a) => Color cs a -> Color cs 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 = 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 = inpmDerive gamut + {-# INLINE inpm #-} + + -- | Lift RGB color model into a RGB color space + mkColorRGB :: Color CM.RGB e -> Color cs e + default mkColorRGB :: + Coercible (Color CM.RGB e) (Color cs e) => Color CM.RGB e -> Color cs e + mkColorRGB = coerce + + -- | Drop RGB color space down to the RGB color model + unColorRGB :: Color cs e -> Color CM.RGB e + default unColorRGB :: + Coercible (Color cs e) (Color CM.RGB e) => Color cs e -> Color CM.RGB e + unColorRGB = coerce + + +data Gamut cs i e = Gamut + { gamutRedPrimary :: !(Primary i e) + , gamutGreenPrimary :: !(Primary i e) + , 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 + +-- | Get the `WhitePoint` of chromaticity. `Chromaticity` itself isn't actually evaluated, +-- its type carries enough information for this operation. +-- +-- @since 0.1.0 +gamutWhitePoint :: (RedGreenBlue cs i, RealFloat e) => Gamut cs i e -> WhitePoint i e +gamutWhitePoint _ = whitePoint +{-# INLINE gamutWhitePoint #-} + + +-- | Linear transformation of a pixel in a linear RGB color space into XYZ color space +-- +-- ==== __Examples__ +-- +-- This example depicts the fact that even in @ghci@ when @npm@ is instantiated to a +-- concrete type, despite being derived it is memoized and gets computed only once. +-- +-- >>> :set -XDataKinds +-- >>> import Debug.Trace +-- >>> import Graphics.Color.Illuminant.CIE1931 +-- >>> import Graphics.Color.Space.RGB.Derived.SRGB +-- >>> :{ +-- srgbFromLinear :: Color (SRGB 'D65) 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 +-- +-- >>> srgbFromLinear $ ColorRGB 0.1 0.2 0.3 +-- +-- >>> rgb = ColorRGB 0.1 0.2 0.3 :: Color (SRGB 'D65) Float +-- >>> npmApply npm rgb :: Color (XYZ 'D65) Float +-- +-- +-- Here is a comparison with a non-liner sRGB conversion: +-- +-- >>> 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 (NPM npm') = coerce . multM3x3byV3 npm' . coerce . unColorRGB +{-# INLINE npmApply #-} + +-- | Linear transformation of a pixel in XYZ color space into a linear RGB color space +-- +-- @since 0.1.0 +inpmApply :: + (RedGreenBlue cs i, Elevator e) => INPM cs e -> Color (XYZ i) e -> Color cs 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 + -> Color (Y i) e +npmApplyLuminance px = Y (m3x3row1 (unNPM (npm :: NPM cs e)) `dotProduct` coerce (unColorRGB px)) +{-# INLINE npmApplyLuminance #-} + + +rgbLuminance :: (RedGreenBlue cs i, ColorSpace cs i e, RealFloat e) => Color cs e -> Color (Y i) e +rgbLuminance = npmApplyLuminance . dcctf +{-# INLINE rgbLuminance #-} + +rgb2xyz :: (RedGreenBlue cs i, ColorSpace cs i e, RealFloat e) => Color cs e -> Color (XYZ i) e +rgb2xyz = npmApply npm . dcctf +{-# INLINE rgb2xyz #-} + +xyz2rgb :: + (RedGreenBlue cs i, ColorSpace cs i e, RealFloat e) + => Color (XYZ i) e + -> Color cs e +xyz2rgb = ecctf . inpmApply inpm +{-# INLINE xyz2rgb #-} + +-- | Constructor for an RGB color space. +pattern ColorRGB :: RedGreenBlue cs i => e -> e -> e -> Color cs 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 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 #-} + + +-- newtype ConversionMatrix cs' cs = ConversionMatrix M3x3 + +-- conversionMatrix :: +-- forall cs' i' cs i. (RedGreenBlue cs' i', RedGreenBlue cs i) +-- => ConversionMatrix (cs' i') (cs i) +-- conversionMatrix = +-- ConversionMatrix $ multM3x3byM3x3 (unINPM (inpm :: INPM cs i)) (unNPM (npm :: NPM cs' i')) + +-- makeConversionMatrix :: +-- forall cta cs' i' cs i. (RedGreenBlue cs' i', RedGreenBlue cs i) +-- => cta -> ConversionMatrix (cs' i') (cs i) +-- makeConversionMatrix _cta = +-- ConversionMatrix $ multM3x3byM3x3 (unINPM (inpm :: INPM cs i)) (unNPM (npm :: NPM cs' i')) + + +-- applyConversionMatrix :: +-- (RedGreenBlue cs1 i1, RedGreenBlue cs2 i2, Elevator e2, Elevator e1) +-- => ConversionMatrix (cs1 i1) (cs2 i2) +-- -> Color (cs1 i1) e1 +-- -> Color (cs2 i2) e2 +-- applyConversionMatrix (ConversionMatrix m) px = +-- mkColorRGB $ fromV3 CM.ColorRGB $ multM3x3byV3 m (toV3 r g b) +-- where +-- CM.ColorRGB r g b = unColorRGB px + +-- | Normalized primary matrix (NPM), which is used to tranform linear RGB color space +-- into `Graphics.Color.Space.CIE1931.XYZ.XYZ` color space. +-- +-- @since 0.1.0 +newtype NPM cs e = NPM + { unNPM :: M3x3 e + } deriving (Eq, Functor, Applicative, Foldable, Traversable) + +instance ColorSpace cs i e => Show (NPM cs e) where + show = show . unNPM + +-- | Inverse normalized primary matrix (iNPM), which is used to tranform linear +-- `Graphics.Color.Space.CIE1931.XYZ.XYZ` color space into a linear RGB color space. It is +-- literally a inverse matrix of `NPM` +-- +-- @since 0.1.0 +newtype INPM cs e = INPM + { unINPM :: M3x3 e + } deriving (Eq, Functor, Applicative, Foldable, Traversable) + +instance Elevator e => Show (INPM cs e) where + show = show . unINPM + + +-- | Derive a `NPM` form chromaticities and a white point +-- +-- @since 0.1.0 +npmDerive :: + forall cs i e. (ColorSpace cs i e, RealFloat e) + => Gamut cs i e + -> NPM cs e +npmDerive (Gamut r g b) = NPM (primaries' * M3x3 coeff coeff coeff) + where + !primaries' = + toRealFloat <$> + -- transposed matrix with xyz primaries + M3x3 + (V3 (xPrimary r) (xPrimary g) (xPrimary b)) + (V3 (yPrimary r) (yPrimary g) (yPrimary b)) + (V3 (zPrimary r) (zPrimary g) (zPrimary b)) + !coeff = invertM3x3 primaries' `multM3x3byV3` coerce (whitePointTristimulus :: Color (XYZ i) e) +{-# INLINE npmDerive #-} + +-- | Derive an `INPM` form chromaticities and a white point +-- +-- @since 0.1.0 +inpmDerive :: + forall cs i e. (ColorSpace cs i e, RealFloat e) + => Gamut cs i e + -> INPM cs e +inpmDerive = INPM . invertM3x3 . unNPM . npmDerive +{-# INLINE inpmDerive #-} + + + +-- | Get the `Chromaticity` of a pixel in RGB color space. Color itself isn't actually +-- 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 _ = gamut +{-# INLINE rgbColorGamut #-} + + +-- | Get the white point of any RGB pixel. Color itself isn't evaluated, since its type +-- carries enough information for getting the white point. +-- +-- >>> 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 )) +-- +-- @since 0.1.0 +pixelWhitePoint :: + forall e cs a i. (RedGreenBlue cs i, RealFloat e) + => Color cs 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 new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/Luma.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.RGB.Luma +-- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.Luma + ( Y' + -- * Constructors for Luma. + , pattern Y' + , Color + , Luma(..) + , Weight(..) + , rgbLuma + , rgbLumaWeights + ) where + +import Data.Coerce +import Foreign.Storable +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.RGB as CM +import Graphics.Color.Model.Internal +import Graphics.Color.Model.Y +import Graphics.Color.Space.RGB.Internal + +------------- +--- Luma ---- +------------- + +-- | [Luma](https://en.wikipedia.org/wiki/Luma_(video\)) of a non-linear gamma corrected +-- RGB color space. +data Y' + +-- | Constructor for Luma. +newtype instance Color Y' e = Y' e + +-- | `Y'` color model +deriving instance Eq e => Eq (Color Y' e) +-- | `Y'` color model +deriving instance Ord e => Ord (Color Y' e) +-- | `Y'` color model +deriving instance Storable e => Storable (Color Y' e) + + +-- | `Y'` color model +instance Elevator e => Show (Color Y' e) where + showsPrec _ = showsColorModel + +-- | `Y'` color model +instance Elevator e => ColorModel Y' e where + type Components Y' e = e + toComponents (Y' y) = y + {-# INLINE toComponents #-} + fromComponents = Y' + {-# INLINE fromComponents #-} + +-- | `Y'` color model +instance Functor (Color Y') where + fmap f (Y' y) = Y' (f y) + {-# INLINE fmap #-} + +-- | `Y'` color model +instance Applicative (Color Y') where + pure = Y' + {-# INLINE pure #-} + (Y' fy) <*> (Y' y) = Y' (fy y) + {-# INLINE (<*>) #-} + +-- | `Y'` color model +instance Foldable (Color Y') where + foldr f !z (Y' y) = f y z + {-# INLINE foldr #-} + +-- | `Y'` color model +instance Traversable (Color Y') where + traverse f (Y' y) = Y' <$> f y + {-# INLINE traverse #-} + + + +------------------ +-- Luma Weights -- +------------------ + +class Luma cs where + {-# MINIMAL (rWeight, gWeight)|(rWeight, bWeight)|(gWeight, bWeight) #-} + rWeight :: RealFloat e => Weight cs e + rWeight = 1 - bWeight - gWeight + {-# INLINE rWeight #-} + + gWeight :: RealFloat e => Weight cs e + gWeight = 1 - rWeight - bWeight + {-# INLINE gWeight #-} + + bWeight :: RealFloat e => Weight cs e + bWeight = 1 - rWeight - gWeight + {-# INLINE bWeight #-} + +newtype Weight cs e = Weight + { unWeight :: e + } deriving (Eq, Show, Num, Fractional, Floating) + + +rgbLumaWeights :: + forall cs e' e. (Luma cs, RealFloat e) + => Color cs e' + -> Weights e +rgbLumaWeights _ = + Weights (V3 (coerce (rWeight :: Weight cs e) :: e) + (coerce (gWeight :: Weight cs e) :: e) + (coerce (bWeight :: Weight cs e) :: e)) +{-# INLINE rgbLumaWeights #-} + +-- | Convert a non-linear RGB pixel to a luma pixel +rgbLuma :: + forall cs i e' e. (Luma cs, RedGreenBlue cs i, Elevator e', Elevator e, RealFloat e) + => Color cs e' + -> Color Y' e +rgbLuma rgb' = Y' (coerce (fmap toRealFloat rgb :: Color CM.RGB e) `dotProduct` coerce weights) + where + !rgb = unColorRGB rgb' + !weights = rgbLumaWeights rgb' :: Weights e +{-# INLINE rgbLuma #-} diff --git a/src/Graphics/Color/Space/RGB/SRGB.hs b/src/Graphics/Color/Space/RGB/SRGB.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Space/RGB/SRGB.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Color.Space.RGB.SRGB +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Space.RGB.SRGB + ( -- * Constructors for a sRGB color space. + pattern SRGB + , pattern ColorSRGB + , pattern ColorSRGBA + , SRGB + , D50 + , D65 + , primaries + , npmStandard + , inpmStandard + , transfer + , itransfer + ) where + +import Foreign.Storable +import Graphics.Color.Model.Alpha +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) + +-- | The most common [sRGB](https://en.wikipedia.org/wiki/SRGB) color space with the +-- default `D65` illuminant +data SRGB + + +newtype instance Color SRGB 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 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 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) + +-- | s`RGB` color space +instance Elevator e => Show (Color SRGB e) where + showsPrec _ = showsColorModel + +-- | s`RGB` color space +instance Elevator e => ColorModel SRGB e where + type Components SRGB 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 + toBaseSpace = id + {-# INLINE toBaseSpace #-} + fromBaseSpace = id + {-# INLINE fromBaseSpace #-} + luminance = rgbLuminance . fmap toRealFloat + {-# INLINE luminance #-} + toColorXYZ = rgb2xyz . fmap toRealFloat + {-# INLINE toColorXYZ #-} + fromColorXYZ = fmap fromRealFloat . xyz2rgb + {-# INLINE fromColorXYZ #-} + +-- | s`RGB` color space +instance RedGreenBlue SRGB D65 where + gamut = primaries + npm = npmStandard + inpm = inpmStandard + ecctf = fmap transfer + {-# INLINE ecctf #-} + dcctf = fmap itransfer + {-# INLINE dcctf #-} + +instance Luma SRGB where + rWeight = 0.299 + gWeight = 0.587 + bWeight = 0.114 + + +-- | sRGB normalized primary matrix. This is a helper definition, use `npm` instead. +-- +-- >>> :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 ] ] +-- +-- @since 0.1.0 +npmStandard :: RealFloat a => NPM SRGB a +npmStandard = NPM $ M3x3 (V3 0.4124 0.3576 0.1805) + (V3 0.2126 0.7152 0.0722) + (V3 0.0193 0.1192 0.9505) + + +-- | sRGB inverse normalized primary matrix. This is a helper definition, use `inpm` instead. +-- +-- >>> :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 ] ] +-- +-- @since 0.1.0 +inpmStandard :: RealFloat a => INPM SRGB a +inpmStandard = INPM $ M3x3 (V3 3.2406 -1.5372 -0.4986) + (V3 -0.9689 1.8758 0.0415) + (V3 0.0557 -0.2040 1.0570) + + +-- | sRGB transfer function "gamma". This is a helper function, therefore `ecctf` should be used +-- instead. +-- +-- \[ +-- \gamma(u) = \begin{cases} +-- 12.92 u & u \leq 0.0031308 \\ +-- 1.055 u^{1/2.4} - 0.055 & \text{otherwise} +-- \end{cases} +-- \] +-- +-- @since 0.1.0 +transfer :: (Ord a, Floating a) => a -> a +transfer u + | u <= 0.0031308 = 12.92 * u + | otherwise = 1.055 * (u ** (1 / 2.4)) - 0.055 +{-# INLINE transfer #-} + +-- | sRGB inverse transfer function "gamma". This is a helper function, therefore `dcctf` should +-- be used instead. +-- +-- \[ +-- \gamma^{-1}(u) = \begin{cases} +-- u / 12.92 & u \leq 0.04045 \\ +-- \left(\tfrac{u + 0.055}{1.055}\right)^{2.4} & \text{otherwise} +-- \end{cases} +-- \] +-- +-- @since 0.1.0 +itransfer :: (Ord a, Floating a) => a -> a +itransfer u + | u <= 0.04045 = u / 12.92 + | otherwise = ((u + 0.055) / 1.055) ** 2.4 +{-# INLINE itransfer #-} diff --git a/src/Graphics/Color/Standard/RAL.hs b/src/Graphics/Color/Standard/RAL.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Color/Standard/RAL.hs @@ -0,0 +1,1139 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +-- | +-- Module : Graphics.Color.Standard.RAL +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Color.Standard.RAL + ( RAL(..) + , D50 + , greenBeige + , beige + , sandYellow + , signalYellow + , goldenYellow + , honeyYellow + , maizeYellow + , daffodilYellow + , brownBeige + , lemonYellow + , oysterWhite + , ivory + , lightIvory + , sulfurYellow + , saffronYellow + , zincYellow + , greyBeige + , oliveYellow + , rapeYellow + , trafficYellow + , ochreYellow + , luminousYellow + , curryYellow + , melonYellow + , broomYellow + , dahliaYellow + , pastelYellow + , pearlBeige + , pearlGold + , sunYellow + , yellowOrange + , redOrange + , vermilion + , pastelOrange + , pureOrange + , luminousOrange + , luminousBrightOrange + , brightRedOrange + , trafficOrange + , signalOrange + , deepOrange + , salmonOrange + , pearlOrange + , flameRed + , signalRed + , carmineRed + , rubyRed + , purpleRed + , wineRed + , blackRed + , oxideRed + , brownRed + , beigeRed + , tomatoRed + , antiquePink + , lightPink + , coralRed + , rose + , strawberryRed + , trafficRed + , salmonPink + , luminousRed + , luminousBrightRed + , raspberryRed + , pureRed + , orientRed + , pearlRubyRed + , pearlPink + , redLilac + , redViolet + , heatherViolet + , claretViolet + , blueLilac + , trafficPurple + , purpleViolet + , signalViolet + , pastelViolet + , telemagenta + , pearlViolet + , pearlBlackberry + , violetBlue + , greenBlue + , ultramarineBlue + , sapphireBlue + , blackBlue + , signalBlue + , brilliantBlue + , greyBlue + , azureBlue + , gentianBlue + , steelBlue + , lightBlue + , cobaltBlue + , pigeonBlue + , skyBlue + , trafficBlue + , turquoiseBlue + , capriBlue + , oceanBlue + , waterBlue + , nightBlue + , distantBlue + , pastelBlue + , pearlGentianBlue + , pearlNightBlue + , patinaGreen + , emeraldGreen + , leafGreen + , oliveGreen + , blueGreen + , mossGreen + , greyOlive + , bottleGreen + , brownGreen + , firGreen + , grassGreen + , resedaGreen + , blackGreen + , reedGreen + , yellowOlive + , blackOlive + , turquoiseGreen + , mayGreen + , yellowGreen + , pastelGreen + , chromeGreen + , paleGreen + , oliveDrab + , trafficGreen + , fernGreen + , opalGreen + , lightGreen + , pineGreen + , mintGreen + , signalGreen + , mintTurquoise + , pastelTurquoise + , pearlGreen + , pearlOpalGreen + , pureGreen + , luminousGreen + , squirrelGrey + , silverGrey + , oliveGrey + , mossGrey + , signalGrey + , mouseGrey + , beigeGrey + , khakiGrey + , greenGrey + , tarpaulinGrey + , ironGrey + , basaltGrey + , brownGrey + , slateGrey + , anthraciteGrey + , blackGrey + , umbraGrey + , concreteGrey + , graphiteGrey + , graniteGrey + , stoneGrey + , blueGrey + , pebbleGrey + , cementGrey + , yellowGrey + , lightGrey + , platinumGrey + , dustyGrey + , agateGrey + , quartzGrey + , windowGrey + , trafficGreyA + , trafficGreyB + , silkGrey + , telegrey1 + , telegrey2 + , telegrey4 + , pearlMouseGrey + , greenBrown + , ochreBrown + , signalBrown + , clayBrown + , copperBrown + , fawnBrown + , oliveBrown + , nutBrown + , redBrown + , sepiaBrown + , chestnutBrown + , mahoganyBrown + , chocolateBrown + , greyBrown + , blackBrown + , orangeBrown + , beigeBrown + , paleBrown + , terraBrown + , pearlCopper + , cream + , greyWhite + , signalWhite + , signalBlack + , jetBlack + , whiteAluminium + , greyAluminium + , pureWhite + , graphiteBlack + , trafficWhite + , trafficBlack + , papyrusWhite + , pearlLightGrey + , pearlDarkGrey + , StandardColor(..) + ) where + +import Data.Typeable +import Graphics.Color.Space +import Graphics.Color.Space.CIE1976.LAB +import Graphics.Color.Adaptation.VonKries +import Graphics.Color.Space.RGB.SRGB + +-- -- TODO: Find a home somewhere for this common illuminant +-- data D50 + +-- -- | @[x=0.44758, y=0.40745]@ - CIE 1931 2° Observer - Used for definition of RAL +-- instance Illuminant D50 where +-- type Temperature D50 = 5003 +-- whitePoint = WhitePoint 0.3457 0.3585 +-- -- 0.345704, y = 0.358540 -- << PhotoRGB + +class StandardColor std code where + + color :: ColorSpace cs i e => std code -> Color cs e + + +-- | Source: https://en.wikipedia.org/wiki/List_of_RAL_colors +data RAL (n :: k) = RAL + +instance (Typeable n, Typeable k) => Show (RAL (n :: k)) where + showsPrec n c + | n == 0 = p . showsType c + | otherwise = ('(' :) . p . showsType c . (')' :) + where + p = ("RAL " ++) + + +greenBeige + , beige + , sandYellow + , signalYellow + , goldenYellow + , honeyYellow + , maizeYellow + , daffodilYellow + , brownBeige + , lemonYellow + , oysterWhite + , ivory + , lightIvory + , sulfurYellow + , saffronYellow + , zincYellow + , greyBeige + , oliveYellow + , rapeYellow + , trafficYellow + , ochreYellow + , luminousYellow + , curryYellow + , melonYellow + , broomYellow + , dahliaYellow + , pastelYellow + , pearlBeige + , pearlGold + , sunYellow + , yellowOrange + , redOrange + , vermilion + , pastelOrange + , pureOrange + , luminousOrange + , luminousBrightOrange + , brightRedOrange + , trafficOrange + , signalOrange + , deepOrange + , salmonOrange + , pearlOrange + , flameRed + , signalRed + , carmineRed + , rubyRed + , purpleRed + , wineRed + , blackRed + , oxideRed + , brownRed + , beigeRed + , tomatoRed + , antiquePink + , lightPink + , coralRed + , rose + , strawberryRed + , trafficRed + , salmonPink + , luminousRed + , luminousBrightRed + , raspberryRed + , pureRed + , orientRed + , pearlRubyRed + , pearlPink + , redLilac + , redViolet + , heatherViolet + , claretViolet + , blueLilac + , trafficPurple + , purpleViolet + , signalViolet + , pastelViolet + , telemagenta + , pearlViolet + , pearlBlackberry + , violetBlue + , greenBlue + , ultramarineBlue + , sapphireBlue + , blackBlue + , signalBlue + , brilliantBlue + , greyBlue + , azureBlue + , gentianBlue + , steelBlue + , lightBlue + , cobaltBlue + , pigeonBlue + , skyBlue + , trafficBlue + , turquoiseBlue + , capriBlue + , oceanBlue + , waterBlue + , nightBlue + , distantBlue + , pastelBlue + , pearlGentianBlue + , pearlNightBlue + , patinaGreen + , emeraldGreen + , leafGreen + , oliveGreen + , blueGreen + , mossGreen + , greyOlive + , bottleGreen + , brownGreen + , firGreen + , grassGreen + , resedaGreen + , blackGreen + , reedGreen + , yellowOlive + , blackOlive + , turquoiseGreen + , mayGreen + , yellowGreen + , pastelGreen + , chromeGreen + , paleGreen + , oliveDrab + , trafficGreen + , fernGreen + , opalGreen + , lightGreen + , pineGreen + , mintGreen + , signalGreen + , mintTurquoise + , pastelTurquoise + , pearlGreen + , pearlOpalGreen + , pureGreen + , luminousGreen + , squirrelGrey + , silverGrey + , oliveGrey + , mossGrey + , signalGrey + , mouseGrey + , beigeGrey + , khakiGrey + , greenGrey + , tarpaulinGrey + , ironGrey + , basaltGrey + , brownGrey + , slateGrey + , anthraciteGrey + , blackGrey + , umbraGrey + , concreteGrey + , graphiteGrey + , graniteGrey + , stoneGrey + , blueGrey + , pebbleGrey + , cementGrey + , yellowGrey + , lightGrey + , platinumGrey + , dustyGrey + , agateGrey + , quartzGrey + , windowGrey + , trafficGreyA + , trafficGreyB + , silkGrey + , telegrey1 + , telegrey2 + , telegrey4 + , pearlMouseGrey + , greenBrown + , ochreBrown + , signalBrown + , clayBrown + , copperBrown + , fawnBrown + , oliveBrown + , nutBrown + , redBrown + , sepiaBrown + , chestnutBrown + , mahoganyBrown + , chocolateBrown + , greyBrown + , blackBrown + , orangeBrown + , beigeBrown + , paleBrown + , terraBrown + , pearlCopper + , cream + , greyWhite + , signalWhite + , signalBlack + , jetBlack + , whiteAluminium + , greyAluminium + , pureWhite + , graphiteBlack + , trafficWhite + , trafficBlack + , papyrusWhite + , pearlLightGrey + , pearlDarkGrey + :: ColorSpace cs i e => Color cs e + +ral :: ColorSpace cs i e => Float -> Float -> Float -> Color cs e +ral l' a' b' = convert (ColorLAB l' a' b' :: Color (LAB D50) Float) + +greenBeige = ral 76.022 -0.366 27.636 +beige = ral 73.595 5.518 26.95 +sandYellow = ral 71.934 7.362 36.744 +signalYellow = ral 75.041 19.801 80.264 +goldenYellow = ral 70.089 16.1 78.815 +honeyYellow = ral 63.448 13.382 74.694 +maizeYellow = ral 66.562 22.472 76.492 +daffodilYellow = ral 66.5 27.308 80.402 +brownBeige = ral 57.338 12.518 33.353 +lemonYellow = ral 73.615 4.946 68.938 +oysterWhite = ral 87.152 0.27 10.431 +ivory = ral 80.411 2.763 24.175 +lightIvory = ral 85.219 2.394 16.821 +sulfurYellow = ral 87.29 -9.283 76.694 +saffronYellow = ral 75.183 20.633 55.581 +zincYellow = ral 83.353 3.462 75.829 +greyBeige = ral 60.643 4.702 13.952 +oliveYellow = ral 59.883 0.56 24.683 +rapeYellow = ral 77.828 10.664 94.6 +trafficYellow = ral 77.72 11.334 93.913 +ochreYellow = ral 62.261 8.491 41.488 +luminousYellow = ral 99.618 -17.229 116.966 +curryYellow = ral 55.557 6.493 58.255 +melonYellow = ral 73.671 31.654 95.458 +broomYellow = ral 71.135 12.766 74.772 +dahliaYellow = ral 71.74 27.78 71.677 +pastelYellow = ral 70.94 22.91 49.962 +pearlBeige = ral 55.258 1.866 11.775 +pearlGold = ral 44.425 6.462 25.001 +sunYellow = ral 68.889 27.62 74.504 +yellowOrange = ral 58.201 37.297 68.683 +redOrange = ral 45.824 44.129 47.554 +vermilion = ral 44.441 52.797 43.768 +pastelOrange = ral 64.235 44.142 61.832 +pureOrange = ral 54.448 53.586 63.716 +luminousOrange = ral 72.274 87.783 82.315 +luminousBrightOrange = ral 88.914 52.782 97.982 +brightRedOrange = ral 60.334 46.913 60.652 +trafficOrange = ral 53.766 51.886 62.145 +signalOrange = ral 53.28 42.985 49.867 +deepOrange = ral 59.241 40.856 64.504 +salmonOrange = ral 56.085 42.492 34.021 +pearlOrange = ral 37.341 33.898 32.139 +flameRed = ral 37.687 50.439 36.563 +signalRed = ral 34.702 48.478 31.204 +carmineRed = ral 34.458 48.832 31.869 +rubyRed = ral 29.149 45.067 24.389 +purpleRed = ral 23.903 35.433 16.085 +wineRed = ral 19.699 30.019 12.525 +blackRed = ral 16.437 14.617 5.268 +oxideRed = ral 27.272 24.588 16.512 +brownRed = ral 27.966 36.64 21.316 +beigeRed = ral 61.394 22.436 22.979 +tomatoRed = ral 35.45 43.402 30.523 +antiquePink = ral 58.26 34.939 14.085 +lightPink = ral 71.232 21.595 4.983 +coralRed = ral 40.678 42.925 30.919 +rose = ral 51.708 47.655 19.335 +strawberryRed = ral 47.141 54.458 24.604 +trafficRed = ral 40.511 59.32 47.967 +salmonPink = ral 56.056 38.9 29.704 +luminousRed = ral 61.253 83.212 65.195 +luminousBrightRed = ral 63.701 87.132 70.01 +raspberryRed = ral 38.686 53.68 20.868 +pureRed = ral 45.358 60.958 44.231 +orientRed = ral 39.32 47.086 24.708 +pearlRubyRed = ral 25.034 36.705 17.139 +pearlPink = ral 39.808 43.686 30.991 +redLilac = ral 45.333 19.568 -14.009 +redViolet = ral 36.8 35.858 8.343 +heatherViolet = ral 54.247 44.659 -5.015 +claretViolet = ral 23.577 34.298 0.517 +blueLilac = ral 47.024 16.762 -25.226 +trafficPurple = ral 36.964 46.56 -16.759 +purpleViolet = ral 19.721 20.17 -7.946 +signalViolet = ral 40.761 32.526 -20.561 +pastelViolet = ral 58.22 11.056 -3.283 +telemagenta = ral 46.538 54.36 -4.083 +pearlViolet = ral 44.108 12.383 -18.407 +pearlBlackberry = ral 45.891 4.098 -11.086 +violetBlue = ral 32.585 -1.282 -21.686 +greenBlue = ral 29.866 -9.761 -19.22 +ultramarineBlue = ral 24.179 11.008 -42.748 +sapphireBlue = ral 22.956 0.076 -20.213 +blackBlue = ral 11.174 0.654 -7.457 +signalBlue = ral 32.448 -6.68 -37.201 +brilliantBlue = ral 42.929 -6.8 -23.609 +greyBlue = ral 23.463 -3.174 -8.172 +azureBlue = ral 37.421 -10.799 -19.905 +gentianBlue = ral 30.95 -7.433 -32.954 +steelBlue = ral 16.969 -1.198 -13.154 +lightBlue = ral 53.135 -15.219 -32.486 +cobaltBlue = ral 20.044 2.964 -23.406 +pigeonBlue = ral 51.233 -2.817 -16.741 +skyBlue = ral 48.193 -13.907 -36.485 +trafficBlue = ral 34.824 -13.495 -36.357 +turquoiseBlue = ral 52.285 -30.312 -9.335 +capriBlue = ral 36.615 -11.411 -28.473 +oceanBlue = ral 23.75 -20.682 -12.512 +waterBlue = ral 43.325 -33.797 -10.417 +nightBlue = ral 19.872 10.632 -28.485 +distantBlue = ral 43.013 -3.442 -23.737 +pastelBlue = ral 58.295 -10.309 -18.647 +pearlGentianBlue = ral 41.102 -15.762 -16.748 +pearlNightBlue = ral 19.227 1.728 -24.359 +patinaGreen = ral 44.529 -23.651 5.316 +emeraldGreen = ral 39.247 -28.094 23.342 +leafGreen = ral 34.079 -24.697 23.999 +oliveGreen = ral 34.335 -5.296 13.147 +blueGreen = ral 25.484 -19.095 -4.31 +mossGreen = ral 24.439 -20.569 4.665 +greyOlive = ral 24.036 -1.163 7.105 +bottleGreen = ral 19.792 -6.46 9.562 +brownGreen = ral 21.675 -0.827 6.489 +firGreen = ral 20.78 -8.546 5.213 +grassGreen = ral 42.993 -22.872 26.093 +resedaGreen = ral 49.931 -12.896 17.344 +blackGreen = ral 24.554 -6.234 -0.13 +reedGreen = ral 49.493 -2.158 16.371 +yellowOlive = ral 27.639 0.59 7.89 +blackOlive = ral 25.484 -1.59 4.15 +turquoiseGreen = ral 38.439 -39.355 8.026 +mayGreen = ral 49.029 -25.488 29.753 +yellowGreen = ral 57.587 -35.153 42.334 +pastelGreen = ral 80.385 -13.069 14.476 +chromeGreen = ral 26.338 -8.365 10.002 +paleGreen = ral 61.305 -11.717 16.056 +oliveDrab = ral 21.685 1.103 8.802 +trafficGreen = ral 47.925 -44.563 18.534 +fernGreen = ral 43.932 -15.048 26.076 +opalGreen = ral 34.35 -36.57 0.829 +lightGreen = ral 71.56 -20.503 -3.86 +pineGreen = ral 32.5 -17.091 6.069 +mintGreen = ral 39.92 -47.213 19.273 +signalGreen = ral 47.236 -37.788 16.942 +mintTurquoise = ral 51.934 -22.925 -2.331 +pastelTurquoise = ral 67.128 -16.7 -5.213 +pearlGreen = ral 28.366 -27.124 18.409 +pearlOpalGreen = ral 32.729 -25.854 0.881 +pureGreen = ral 50.209 -53.031 41.386 +luminousGreen = ral 62.308 -84.293 57.548 +squirrelGrey = ral 55.673 -3.552 -4.905 +silverGrey = ral 61.648 -2.346 -4.456 +oliveGrey = ral 50.775 -0.044 12.64 +mossGrey = ral 49.694 -1.244 7.793 +signalGrey = ral 63.832 0.185 -0.439 +mouseGrey = ral 46.213 -1.581 1.174 +beigeGrey = ral 45.607 2.498 8.713 +khakiGrey = ral 41.485 4.118 22.658 +greenGrey = ral 40.2 -2.864 4.187 +tarpaulinGrey = ral 38.442 -2.331 2.593 +ironGrey = ral 37.44 -2.068 -3.02 +basaltGrey = ral 39.159 -2.027 -1.452 +brownGrey = ral 34.343 0.836 8.009 +slateGrey = ral 35.155 -0.229 -3.737 +anthraciteGrey = ral 25.926 -1.853 -3.407 +blackGrey = ral 20.639 -0.806 -1.325 +umbraGrey = ral 31.372 -0.001 3.652 +concreteGrey = ral 53.265 -1.634 5.038 +graphiteGrey = ral 30.964 -0.314 -3.685 +graniteGrey = ral 27.434 -4.013 -3.107 +stoneGrey = ral 59.041 -0.114 5.3 +blueGrey = ral 43.16 -3.593 -4.523 +pebbleGrey = ral 71.941 -0.909 8.469 +cementGrey = ral 53.842 -3.737 7.189 +yellowGrey = ral 56.857 0.031 14.835 +lightGrey = ral 80.047 -1.207 1.387 +platinumGrey = ral 61.233 1.346 1.022 +dustyGrey = ral 51.431 -0.642 0.533 +agateGrey = ral 71.73 -1.62 3.82 +quartzGrey = ral 43.496 0.373 5.56 +windowGrey = ral 64.7 -1.517 -2.498 +trafficGreyA = ral 60.149 -1.676 0.035 +trafficGreyB = ral 34.565 -1.532 0.596 +silkGrey = ral 72.904 -0.082 5.939 +telegrey1 = ral 60.348 -1.428 -1.836 +telegrey2 = ral 55.438 -1.833 -3.188 +telegrey4 = ral 80.668 -0.266 0.82 +pearlMouseGrey = ral 51.991 0.679 5.105 +greenBrown = ral 46.778 7.583 28.693 +ochreBrown = ral 47.08 18.952 39.867 +signalBrown = ral 37.391 16.881 16.707 +clayBrown = ral 37.148 18.589 30.287 +copperBrown = ral 38.964 26.631 27.038 +fawnBrown = ral 33.824 15.336 23.6 +oliveBrown = ral 35.151 13.225 28.492 +nutBrown = ral 27.125 13.264 17.081 +redBrown = ral 27.74 22.005 15.201 +sepiaBrown = ral 24.029 7.289 12.866 +chestnutBrown = ral 25.491 20.675 15.127 +mahoganyBrown = ral 21.4 14.371 13.84 +chocolateBrown = ral 21.544 8.972 7.368 +greyBrown = ral 23.321 2.993 1.467 +blackBrown = ral 8.139 1.932 -0.585 +orangeBrown = ral 45.42 28.236 39.65 +beigeBrown = ral 38.036 14.136 20.822 +paleBrown = ral 39.85 9.63 14.49 +terraBrown = ral 26.58 7.884 13.812 +pearlCopper = ral 34.763 26.058 21.392 +cream = ral 89.616 0.594 8.06 +greyWhite = ral 85.07 -1.04 5.18 +signalWhite = ral 93.223 -0.644 2.45 +signalBlack = ral 17.464 0.429 -0.837 +jetBlack = ral 4.041 0.091 -0.873 +whiteAluminium = ral 66.321 -0.347 0.545 +greyAluminium = ral 55.547 -0.061 2.142 +pureWhite = ral 93.613 -0.425 6.008 +graphiteBlack = ral 16.572 -0.383 -1.735 +trafficWhite = ral 94.843 -0.921 3.28 +trafficBlack = ral 16.521 0.709 -0.582 +papyrusWhite = ral 81.343 -2.293 2.956 +pearlLightGrey = ral 55.474 -0.381 1.165 +pearlDarkGrey = ral 51.274 -0.7 -0.279 + + +instance StandardColor RAL 1000 where color _ = greenBeige +instance StandardColor RAL 1001 where color _ = beige +instance StandardColor RAL 1002 where color _ = sandYellow +instance StandardColor RAL 1003 where color _ = signalYellow +instance StandardColor RAL 1004 where color _ = goldenYellow +instance StandardColor RAL 1005 where color _ = honeyYellow +instance StandardColor RAL 1006 where color _ = maizeYellow +instance StandardColor RAL 1007 where color _ = daffodilYellow +instance StandardColor RAL 1011 where color _ = brownBeige +instance StandardColor RAL 1012 where color _ = lemonYellow +instance StandardColor RAL 1013 where color _ = oysterWhite +instance StandardColor RAL 1014 where color _ = ivory +instance StandardColor RAL 1015 where color _ = lightIvory +instance StandardColor RAL 1016 where color _ = sulfurYellow +instance StandardColor RAL 1017 where color _ = saffronYellow +instance StandardColor RAL 1018 where color _ = zincYellow +instance StandardColor RAL 1019 where color _ = greyBeige +instance StandardColor RAL 1020 where color _ = oliveYellow +instance StandardColor RAL 1021 where color _ = rapeYellow +instance StandardColor RAL 1023 where color _ = trafficYellow +instance StandardColor RAL 1024 where color _ = ochreYellow +instance StandardColor RAL 1026 where color _ = luminousYellow +instance StandardColor RAL 1027 where color _ = curryYellow +instance StandardColor RAL 1028 where color _ = melonYellow +instance StandardColor RAL 1032 where color _ = broomYellow +instance StandardColor RAL 1033 where color _ = dahliaYellow +instance StandardColor RAL 1034 where color _ = pastelYellow +instance StandardColor RAL 1035 where color _ = pearlBeige +instance StandardColor RAL 1036 where color _ = pearlGold +instance StandardColor RAL 1037 where color _ = sunYellow + +instance StandardColor RAL 2000 where color _ = yellowOrange +instance StandardColor RAL 2001 where color _ = redOrange +instance StandardColor RAL 2002 where color _ = vermilion +instance StandardColor RAL 2003 where color _ = pastelOrange +instance StandardColor RAL 2004 where color _ = pureOrange +instance StandardColor RAL 2005 where color _ = luminousOrange +instance StandardColor RAL 2007 where color _ = luminousBrightOrange +instance StandardColor RAL 2008 where color _ = brightRedOrange +instance StandardColor RAL 2009 where color _ = trafficOrange +instance StandardColor RAL 2010 where color _ = signalOrange +instance StandardColor RAL 2011 where color _ = deepOrange +instance StandardColor RAL 2012 where color _ = salmonOrange +instance StandardColor RAL 2013 where color _ = pearlOrange + +instance StandardColor RAL 3000 where color _ = flameRed +instance StandardColor RAL 3001 where color _ = signalRed +instance StandardColor RAL 3002 where color _ = carmineRed +instance StandardColor RAL 3003 where color _ = rubyRed +instance StandardColor RAL 3004 where color _ = purpleRed +instance StandardColor RAL 3005 where color _ = wineRed +instance StandardColor RAL 3007 where color _ = blackRed +instance StandardColor RAL 3009 where color _ = oxideRed +instance StandardColor RAL 3011 where color _ = brownRed +instance StandardColor RAL 3012 where color _ = beigeRed +instance StandardColor RAL 3013 where color _ = tomatoRed +instance StandardColor RAL 3014 where color _ = antiquePink +instance StandardColor RAL 3015 where color _ = lightPink +instance StandardColor RAL 3016 where color _ = coralRed +instance StandardColor RAL 3017 where color _ = rose +instance StandardColor RAL 3018 where color _ = strawberryRed +instance StandardColor RAL 3020 where color _ = trafficRed +instance StandardColor RAL 3022 where color _ = salmonPink +instance StandardColor RAL 3024 where color _ = luminousRed +instance StandardColor RAL 3026 where color _ = luminousBrightRed +instance StandardColor RAL 3027 where color _ = raspberryRed +instance StandardColor RAL 3028 where color _ = pureRed +instance StandardColor RAL 3031 where color _ = orientRed +instance StandardColor RAL 3032 where color _ = pearlRubyRed +instance StandardColor RAL 3033 where color _ = pearlPink + +instance StandardColor RAL 4001 where color _ = redLilac +instance StandardColor RAL 4002 where color _ = redViolet +instance StandardColor RAL 4003 where color _ = heatherViolet +instance StandardColor RAL 4004 where color _ = claretViolet +instance StandardColor RAL 4005 where color _ = blueLilac +instance StandardColor RAL 4006 where color _ = trafficPurple +instance StandardColor RAL 4007 where color _ = purpleViolet +instance StandardColor RAL 4008 where color _ = signalViolet +instance StandardColor RAL 4009 where color _ = pastelViolet +instance StandardColor RAL 4010 where color _ = telemagenta +instance StandardColor RAL 4011 where color _ = pearlViolet +instance StandardColor RAL 4012 where color _ = pearlBlackberry + +instance StandardColor RAL 5000 where color _ = violetBlue +instance StandardColor RAL 5001 where color _ = greenBlue +instance StandardColor RAL 5002 where color _ = ultramarineBlue +instance StandardColor RAL 5003 where color _ = sapphireBlue +instance StandardColor RAL 5004 where color _ = blackBlue +instance StandardColor RAL 5005 where color _ = signalBlue +instance StandardColor RAL 5007 where color _ = brilliantBlue +instance StandardColor RAL 5008 where color _ = greyBlue +instance StandardColor RAL 5009 where color _ = azureBlue +instance StandardColor RAL 5010 where color _ = gentianBlue +instance StandardColor RAL 5011 where color _ = steelBlue +instance StandardColor RAL 5012 where color _ = lightBlue +instance StandardColor RAL 5013 where color _ = cobaltBlue +instance StandardColor RAL 5014 where color _ = pigeonBlue +instance StandardColor RAL 5015 where color _ = skyBlue +instance StandardColor RAL 5017 where color _ = trafficBlue +instance StandardColor RAL 5018 where color _ = turquoiseBlue +instance StandardColor RAL 5019 where color _ = capriBlue +instance StandardColor RAL 5020 where color _ = oceanBlue +instance StandardColor RAL 5021 where color _ = waterBlue +instance StandardColor RAL 5022 where color _ = nightBlue +instance StandardColor RAL 5023 where color _ = distantBlue +instance StandardColor RAL 5024 where color _ = pastelBlue +instance StandardColor RAL 5025 where color _ = pearlGentianBlue +instance StandardColor RAL 5026 where color _ = pearlNightBlue + +instance StandardColor RAL 6000 where color _ = patinaGreen +instance StandardColor RAL 6001 where color _ = emeraldGreen +instance StandardColor RAL 6002 where color _ = leafGreen +instance StandardColor RAL 6003 where color _ = oliveGreen +instance StandardColor RAL 6004 where color _ = blueGreen +instance StandardColor RAL 6005 where color _ = mossGreen +instance StandardColor RAL 6006 where color _ = greyOlive +instance StandardColor RAL 6007 where color _ = bottleGreen +instance StandardColor RAL 6008 where color _ = brownGreen +instance StandardColor RAL 6009 where color _ = firGreen +instance StandardColor RAL 6010 where color _ = grassGreen +instance StandardColor RAL 6011 where color _ = resedaGreen +instance StandardColor RAL 6012 where color _ = blackGreen +instance StandardColor RAL 6013 where color _ = reedGreen +instance StandardColor RAL 6014 where color _ = yellowOlive +instance StandardColor RAL 6015 where color _ = blackOlive +instance StandardColor RAL 6016 where color _ = turquoiseGreen +instance StandardColor RAL 6017 where color _ = mayGreen +instance StandardColor RAL 6018 where color _ = yellowGreen +instance StandardColor RAL 6019 where color _ = pastelGreen +instance StandardColor RAL 6020 where color _ = chromeGreen +instance StandardColor RAL 6021 where color _ = paleGreen +instance StandardColor RAL 6022 where color _ = oliveDrab +instance StandardColor RAL 6024 where color _ = trafficGreen +instance StandardColor RAL 6025 where color _ = fernGreen +instance StandardColor RAL 6026 where color _ = opalGreen +instance StandardColor RAL 6027 where color _ = lightGreen +instance StandardColor RAL 6028 where color _ = pineGreen +instance StandardColor RAL 6029 where color _ = mintGreen +instance StandardColor RAL 6032 where color _ = signalGreen +instance StandardColor RAL 6033 where color _ = mintTurquoise +instance StandardColor RAL 6034 where color _ = pastelTurquoise +instance StandardColor RAL 6035 where color _ = pearlGreen +instance StandardColor RAL 6036 where color _ = pearlOpalGreen +instance StandardColor RAL 6037 where color _ = pureGreen +instance StandardColor RAL 6038 where color _ = luminousGreen + +instance StandardColor RAL 7000 where color _ = squirrelGrey +instance StandardColor RAL 7001 where color _ = silverGrey +instance StandardColor RAL 7002 where color _ = oliveGrey +instance StandardColor RAL 7003 where color _ = mossGrey +instance StandardColor RAL 7004 where color _ = signalGrey +instance StandardColor RAL 7005 where color _ = mouseGrey +instance StandardColor RAL 7006 where color _ = beigeGrey +instance StandardColor RAL 7008 where color _ = khakiGrey +instance StandardColor RAL 7009 where color _ = greenGrey +instance StandardColor RAL 7010 where color _ = tarpaulinGrey +instance StandardColor RAL 7011 where color _ = ironGrey +instance StandardColor RAL 7012 where color _ = basaltGrey +instance StandardColor RAL 7013 where color _ = brownGrey +instance StandardColor RAL 7015 where color _ = slateGrey +instance StandardColor RAL 7016 where color _ = anthraciteGrey +instance StandardColor RAL 7021 where color _ = blackGrey +instance StandardColor RAL 7022 where color _ = umbraGrey +instance StandardColor RAL 7023 where color _ = concreteGrey +instance StandardColor RAL 7024 where color _ = graphiteGrey +instance StandardColor RAL 7026 where color _ = graniteGrey +instance StandardColor RAL 7030 where color _ = stoneGrey +instance StandardColor RAL 7031 where color _ = blueGrey +instance StandardColor RAL 7032 where color _ = pebbleGrey +instance StandardColor RAL 7033 where color _ = cementGrey +instance StandardColor RAL 7034 where color _ = yellowGrey +instance StandardColor RAL 7035 where color _ = lightGrey +instance StandardColor RAL 7036 where color _ = platinumGrey +instance StandardColor RAL 7037 where color _ = dustyGrey +instance StandardColor RAL 7038 where color _ = agateGrey +instance StandardColor RAL 7039 where color _ = quartzGrey +instance StandardColor RAL 7040 where color _ = windowGrey +instance StandardColor RAL 7042 where color _ = trafficGreyA +instance StandardColor RAL 7043 where color _ = trafficGreyB +instance StandardColor RAL 7044 where color _ = silkGrey +instance StandardColor RAL 7045 where color _ = telegrey1 +instance StandardColor RAL 7046 where color _ = telegrey2 +instance StandardColor RAL 7047 where color _ = telegrey4 +instance StandardColor RAL 7048 where color _ = pearlMouseGrey + +instance StandardColor RAL 8000 where color _ = greenBrown +instance StandardColor RAL 8001 where color _ = ochreBrown +instance StandardColor RAL 8002 where color _ = signalBrown +instance StandardColor RAL 8003 where color _ = clayBrown +instance StandardColor RAL 8004 where color _ = copperBrown +instance StandardColor RAL 8007 where color _ = fawnBrown +instance StandardColor RAL 8008 where color _ = oliveBrown +instance StandardColor RAL 8011 where color _ = nutBrown +instance StandardColor RAL 8012 where color _ = redBrown +instance StandardColor RAL 8014 where color _ = sepiaBrown +instance StandardColor RAL 8015 where color _ = chestnutBrown +instance StandardColor RAL 8016 where color _ = mahoganyBrown +instance StandardColor RAL 8017 where color _ = chocolateBrown +instance StandardColor RAL 8019 where color _ = greyBrown +instance StandardColor RAL 8022 where color _ = blackBrown +instance StandardColor RAL 8023 where color _ = orangeBrown +instance StandardColor RAL 8024 where color _ = beigeBrown +instance StandardColor RAL 8025 where color _ = paleBrown +instance StandardColor RAL 8028 where color _ = terraBrown +instance StandardColor RAL 8029 where color _ = pearlCopper + +instance StandardColor RAL 9001 where color _ = cream +instance StandardColor RAL 9002 where color _ = greyWhite +instance StandardColor RAL 9003 where color _ = signalWhite +instance StandardColor RAL 9004 where color _ = signalBlack +instance StandardColor RAL 9005 where color _ = jetBlack +instance StandardColor RAL 9006 where color _ = whiteAluminium +instance StandardColor RAL 9007 where color _ = greyAluminium +instance StandardColor RAL 9010 where color _ = pureWhite +instance StandardColor RAL 9011 where color _ = graphiteBlack +instance StandardColor RAL 9016 where color _ = trafficWhite +instance StandardColor RAL 9017 where color _ = trafficBlack +instance StandardColor RAL 9018 where color _ = papyrusWhite +instance StandardColor RAL 9022 where color _ = pearlLightGrey +instance StandardColor RAL 9023 where color _ = pearlDarkGrey + + +instance StandardColor RAL "Green beige" where color _ = color (RAL :: RAL 1000) +instance StandardColor RAL "Beige" where color _ = color (RAL :: RAL 1001) +instance StandardColor RAL "Sand yellow" where color _ = color (RAL :: RAL 1002) +instance StandardColor RAL "Signal yellow" where color _ = color (RAL :: RAL 1003) +instance StandardColor RAL "Golden yellow" where color _ = color (RAL :: RAL 1004) +instance StandardColor RAL "Honey yellow" where color _ = color (RAL :: RAL 1005) +instance StandardColor RAL "Maize yellow" where color _ = color (RAL :: RAL 1006) +instance StandardColor RAL "Daffodil yellow" where color _ = color (RAL :: RAL 1007) +instance StandardColor RAL "Brown beige" where color _ = color (RAL :: RAL 1011) +instance StandardColor RAL "Lemon yellow" where color _ = color (RAL :: RAL 1012) +instance StandardColor RAL "Oyster white" where color _ = color (RAL :: RAL 1013) +instance StandardColor RAL "Ivory" where color _ = color (RAL :: RAL 1014) +instance StandardColor RAL "Light ivory" where color _ = color (RAL :: RAL 1015) +instance StandardColor RAL "Sulfur yellow" where color _ = color (RAL :: RAL 1016) +instance StandardColor RAL "Saffron yellow" where color _ = color (RAL :: RAL 1017) +instance StandardColor RAL "Zinc yellow" where color _ = color (RAL :: RAL 1018) +instance StandardColor RAL "Grey beige" where color _ = color (RAL :: RAL 1019) +instance StandardColor RAL "Olive yellow" where color _ = color (RAL :: RAL 1020) +instance StandardColor RAL "Rape yellow" where color _ = color (RAL :: RAL 1021) +instance StandardColor RAL "Traffic yellow" where color _ = color (RAL :: RAL 1023) +instance StandardColor RAL "Ochre yellow" where color _ = color (RAL :: RAL 1024) +instance StandardColor RAL "Luminous yellow" where color _ = color (RAL :: RAL 1026) +instance StandardColor RAL "Curry yellow" where color _ = color (RAL :: RAL 1027) +instance StandardColor RAL "Melon yellow" where color _ = color (RAL :: RAL 1028) +instance StandardColor RAL "Broom yellow" where color _ = color (RAL :: RAL 1032) +instance StandardColor RAL "Dahlia yellow" where color _ = color (RAL :: RAL 1033) +instance StandardColor RAL "Pastel yellow" where color _ = color (RAL :: RAL 1034) +instance StandardColor RAL "Pearl beige" where color _ = color (RAL :: RAL 1035) +instance StandardColor RAL "Pearl gold" where color _ = color (RAL :: RAL 1036) +instance StandardColor RAL "Sun yellow" where color _ = color (RAL :: RAL 1037) +instance StandardColor RAL "Yellow orange" where color _ = color (RAL :: RAL 2000) +instance StandardColor RAL "Red orange" where color _ = color (RAL :: RAL 2001) +instance StandardColor RAL "Vermilion" where color _ = color (RAL :: RAL 2002) +instance StandardColor RAL "Pastel orange" where color _ = color (RAL :: RAL 2003) +instance StandardColor RAL "Pure orange" where color _ = color (RAL :: RAL 2004) +instance StandardColor RAL "Luminous orange" where color _ = color (RAL :: RAL 2005) +instance StandardColor RAL "Luminous bright orange" where color _ = color (RAL :: RAL 2007) +instance StandardColor RAL "Bright red orange" where color _ = color (RAL :: RAL 2008) +instance StandardColor RAL "Traffic orange" where color _ = color (RAL :: RAL 2009) +instance StandardColor RAL "Signal orange" where color _ = color (RAL :: RAL 2010) +instance StandardColor RAL "Deep orange" where color _ = color (RAL :: RAL 2011) +instance StandardColor RAL "Salmon orange" where color _ = color (RAL :: RAL 2012) +instance StandardColor RAL "Pearl orange" where color _ = color (RAL :: RAL 2013) +instance StandardColor RAL "Flame red" where color _ = color (RAL :: RAL 3000) +instance StandardColor RAL "Signal red" where color _ = color (RAL :: RAL 3001) +instance StandardColor RAL "Carmine red" where color _ = color (RAL :: RAL 3002) +instance StandardColor RAL "Ruby red" where color _ = color (RAL :: RAL 3003) +instance StandardColor RAL "Purple red" where color _ = color (RAL :: RAL 3004) +instance StandardColor RAL "Wine red" where color _ = color (RAL :: RAL 3005) +instance StandardColor RAL "Black red" where color _ = color (RAL :: RAL 3007) +instance StandardColor RAL "Oxide red" where color _ = color (RAL :: RAL 3009) +instance StandardColor RAL "Brown red" where color _ = color (RAL :: RAL 3011) +instance StandardColor RAL "Beige red" where color _ = color (RAL :: RAL 3012) +instance StandardColor RAL "Tomato red" where color _ = color (RAL :: RAL 3013) +instance StandardColor RAL "Antique pink" where color _ = color (RAL :: RAL 3014) +instance StandardColor RAL "Light pink" where color _ = color (RAL :: RAL 3015) +instance StandardColor RAL "Coral red" where color _ = color (RAL :: RAL 3016) +instance StandardColor RAL "Rose" where color _ = color (RAL :: RAL 3017) +instance StandardColor RAL "Strawberry red" where color _ = color (RAL :: RAL 3018) +instance StandardColor RAL "Traffic red" where color _ = color (RAL :: RAL 3020) +instance StandardColor RAL "Salmon pink" where color _ = color (RAL :: RAL 3022) +instance StandardColor RAL "Luminous red" where color _ = color (RAL :: RAL 3024) +instance StandardColor RAL "Luminous bright red" where color _ = color (RAL :: RAL 3026) +instance StandardColor RAL "Raspberry red" where color _ = color (RAL :: RAL 3027) +instance StandardColor RAL "Pure red" where color _ = color (RAL :: RAL 3028) +instance StandardColor RAL "Orient red" where color _ = color (RAL :: RAL 3031) +instance StandardColor RAL "Pearl ruby red" where color _ = color (RAL :: RAL 3032) +instance StandardColor RAL "Pearl pink" where color _ = color (RAL :: RAL 3033) +instance StandardColor RAL "Red lilac" where color _ = color (RAL :: RAL 4001) +instance StandardColor RAL "Red violet" where color _ = color (RAL :: RAL 4002) +instance StandardColor RAL "Heather violet" where color _ = color (RAL :: RAL 4003) +instance StandardColor RAL "Claret violet" where color _ = color (RAL :: RAL 4004) +instance StandardColor RAL "Blue lilac" where color _ = color (RAL :: RAL 4005) +instance StandardColor RAL "Traffic purple" where color _ = color (RAL :: RAL 4006) +instance StandardColor RAL "Purple violet" where color _ = color (RAL :: RAL 4007) +instance StandardColor RAL "Signal violet" where color _ = color (RAL :: RAL 4008) +instance StandardColor RAL "Pastel violet" where color _ = color (RAL :: RAL 4009) +instance StandardColor RAL "Telemagenta" where color _ = color (RAL :: RAL 4010) +instance StandardColor RAL "Pearl violet" where color _ = color (RAL :: RAL 4011) +instance StandardColor RAL "Pearl blackberry" where color _ = color (RAL :: RAL 4012) +instance StandardColor RAL "Violet blue" where color _ = color (RAL :: RAL 5000) +instance StandardColor RAL "Green blue" where color _ = color (RAL :: RAL 5001) +instance StandardColor RAL "Ultramarine blue" where color _ = color (RAL :: RAL 5002) +instance StandardColor RAL "Sapphire blue" where color _ = color (RAL :: RAL 5003) +instance StandardColor RAL "Black blue" where color _ = color (RAL :: RAL 5004) +instance StandardColor RAL "Signal blue" where color _ = color (RAL :: RAL 5005) +instance StandardColor RAL "Brilliant blue" where color _ = color (RAL :: RAL 5007) +instance StandardColor RAL "Grey blue" where color _ = color (RAL :: RAL 5008) +instance StandardColor RAL "Azure blue" where color _ = color (RAL :: RAL 5009) +instance StandardColor RAL "Gentian blue" where color _ = color (RAL :: RAL 5010) +instance StandardColor RAL "Steel blue" where color _ = color (RAL :: RAL 5011) +instance StandardColor RAL "Light blue" where color _ = color (RAL :: RAL 5012) +instance StandardColor RAL "Cobalt blue" where color _ = color (RAL :: RAL 5013) +instance StandardColor RAL "Pigeon blue" where color _ = color (RAL :: RAL 5014) +instance StandardColor RAL "Sky blue" where color _ = color (RAL :: RAL 5015) +instance StandardColor RAL "Traffic blue" where color _ = color (RAL :: RAL 5017) +instance StandardColor RAL "Turquoise blue" where color _ = color (RAL :: RAL 5018) +instance StandardColor RAL "Capri blue" where color _ = color (RAL :: RAL 5019) +instance StandardColor RAL "Ocean blue" where color _ = color (RAL :: RAL 5020) +instance StandardColor RAL "Water blue" where color _ = color (RAL :: RAL 5021) +instance StandardColor RAL "Night blue" where color _ = color (RAL :: RAL 5022) +instance StandardColor RAL "Distant blue" where color _ = color (RAL :: RAL 5023) +instance StandardColor RAL "Pastel blue" where color _ = color (RAL :: RAL 5024) +instance StandardColor RAL "Pearl gentian blue" where color _ = color (RAL :: RAL 5025) +instance StandardColor RAL "Pearl night blue" where color _ = color (RAL :: RAL 5026) +instance StandardColor RAL "Patina green" where color _ = color (RAL :: RAL 6000) +instance StandardColor RAL "Emerald green" where color _ = color (RAL :: RAL 6001) +instance StandardColor RAL "Leaf green" where color _ = color (RAL :: RAL 6002) +instance StandardColor RAL "Olive green" where color _ = color (RAL :: RAL 6003) +instance StandardColor RAL "Blue green" where color _ = color (RAL :: RAL 6004) +instance StandardColor RAL "Moss green" where color _ = color (RAL :: RAL 6005) +instance StandardColor RAL "Grey olive" where color _ = color (RAL :: RAL 6006) +instance StandardColor RAL "Bottle green" where color _ = color (RAL :: RAL 6007) +instance StandardColor RAL "Brown green" where color _ = color (RAL :: RAL 6008) +instance StandardColor RAL "Fir green" where color _ = color (RAL :: RAL 6009) +instance StandardColor RAL "Grass green" where color _ = color (RAL :: RAL 6010) +instance StandardColor RAL "Reseda green" where color _ = color (RAL :: RAL 6011) +instance StandardColor RAL "Black green" where color _ = color (RAL :: RAL 6012) +instance StandardColor RAL "Reed green" where color _ = color (RAL :: RAL 6013) +instance StandardColor RAL "Yellow olive" where color _ = color (RAL :: RAL 6014) +instance StandardColor RAL "Black olive" where color _ = color (RAL :: RAL 6015) +instance StandardColor RAL "Turquoise green" where color _ = color (RAL :: RAL 6016) +instance StandardColor RAL "May green" where color _ = color (RAL :: RAL 6017) +instance StandardColor RAL "Yellow green" where color _ = color (RAL :: RAL 6018) +instance StandardColor RAL "Pastel green" where color _ = color (RAL :: RAL 6019) +instance StandardColor RAL "Chrome green" where color _ = color (RAL :: RAL 6020) +instance StandardColor RAL "Pale green" where color _ = color (RAL :: RAL 6021) +instance StandardColor RAL "Olive-drab" where color _ = color (RAL :: RAL 6022) +instance StandardColor RAL "Brown olive" where color _ = color (RAL :: RAL 6022) +instance StandardColor RAL "Traffic green" where color _ = color (RAL :: RAL 6024) +instance StandardColor RAL "Fern green" where color _ = color (RAL :: RAL 6025) +instance StandardColor RAL "Opal green" where color _ = color (RAL :: RAL 6026) +instance StandardColor RAL "Light green" where color _ = color (RAL :: RAL 6027) +instance StandardColor RAL "Pine green" where color _ = color (RAL :: RAL 6028) +instance StandardColor RAL "Mint green" where color _ = color (RAL :: RAL 6029) +instance StandardColor RAL "Signal green" where color _ = color (RAL :: RAL 6032) +instance StandardColor RAL "Mint turquoise" where color _ = color (RAL :: RAL 6033) +instance StandardColor RAL "Pastel turquoise" where color _ = color (RAL :: RAL 6034) +instance StandardColor RAL "Pearl green" where color _ = color (RAL :: RAL 6035) +instance StandardColor RAL "Pearl opal green" where color _ = color (RAL :: RAL 6036) +instance StandardColor RAL "Pure green" where color _ = color (RAL :: RAL 6037) +instance StandardColor RAL "Luminous green" where color _ = color (RAL :: RAL 6038) +instance StandardColor RAL "Squirrel grey" where color _ = color (RAL :: RAL 7000) +instance StandardColor RAL "Silver grey" where color _ = color (RAL :: RAL 7001) +instance StandardColor RAL "Olive grey" where color _ = color (RAL :: RAL 7002) +instance StandardColor RAL "Moss grey" where color _ = color (RAL :: RAL 7003) +instance StandardColor RAL "Signal grey" where color _ = color (RAL :: RAL 7004) +instance StandardColor RAL "Mouse grey" where color _ = color (RAL :: RAL 7005) +instance StandardColor RAL "Beige grey" where color _ = color (RAL :: RAL 7006) +instance StandardColor RAL "Khaki grey" where color _ = color (RAL :: RAL 7008) +instance StandardColor RAL "Green grey" where color _ = color (RAL :: RAL 7009) +instance StandardColor RAL "Tarpaulin grey" where color _ = color (RAL :: RAL 7010) +instance StandardColor RAL "Iron grey" where color _ = color (RAL :: RAL 7011) +instance StandardColor RAL "Basalt grey" where color _ = color (RAL :: RAL 7012) +instance StandardColor RAL "Brown grey" where color _ = color (RAL :: RAL 7013) +instance StandardColor RAL "NATO olive" where color _ = color (RAL :: RAL 7013) +instance StandardColor RAL "Slate grey" where color _ = color (RAL :: RAL 7015) +instance StandardColor RAL "Anthracite grey" where color _ = color (RAL :: RAL 7016) +instance StandardColor RAL "Black grey" where color _ = color (RAL :: RAL 7021) +instance StandardColor RAL "Umbra grey" where color _ = color (RAL :: RAL 7022) +instance StandardColor RAL "Concrete grey" where color _ = color (RAL :: RAL 7023) +instance StandardColor RAL "Graphite grey" where color _ = color (RAL :: RAL 7024) +instance StandardColor RAL "Granite grey" where color _ = color (RAL :: RAL 7026) +instance StandardColor RAL "Stone grey" where color _ = color (RAL :: RAL 7030) +instance StandardColor RAL "Blue grey" where color _ = color (RAL :: RAL 7031) +instance StandardColor RAL "Pebble grey" where color _ = color (RAL :: RAL 7032) +instance StandardColor RAL "Cement grey" where color _ = color (RAL :: RAL 7033) +instance StandardColor RAL "Yellow grey" where color _ = color (RAL :: RAL 7034) +instance StandardColor RAL "Light grey" where color _ = color (RAL :: RAL 7035) +instance StandardColor RAL "Platinum grey" where color _ = color (RAL :: RAL 7036) +instance StandardColor RAL "Dusty grey" where color _ = color (RAL :: RAL 7037) +instance StandardColor RAL "Agate grey" where color _ = color (RAL :: RAL 7038) +instance StandardColor RAL "Quartz grey" where color _ = color (RAL :: RAL 7039) +instance StandardColor RAL "Window grey" where color _ = color (RAL :: RAL 7040) +instance StandardColor RAL "Traffic grey A" where color _ = color (RAL :: RAL 7042) +instance StandardColor RAL "Traffic grey B" where color _ = color (RAL :: RAL 7043) +instance StandardColor RAL "Silk grey" where color _ = color (RAL :: RAL 7044) +instance StandardColor RAL "Telegrey 1" where color _ = color (RAL :: RAL 7045) +instance StandardColor RAL "Telegrey 2" where color _ = color (RAL :: RAL 7046) +instance StandardColor RAL "Telegrey 4" where color _ = color (RAL :: RAL 7047) +instance StandardColor RAL "Pearl mouse grey" where color _ = color (RAL :: RAL 7048) +instance StandardColor RAL "Green brown" where color _ = color (RAL :: RAL 8000) +instance StandardColor RAL "Ochre brown" where color _ = color (RAL :: RAL 8001) +instance StandardColor RAL "Signal brown" where color _ = color (RAL :: RAL 8002) +instance StandardColor RAL "Clay brown" where color _ = color (RAL :: RAL 8003) +instance StandardColor RAL "Copper brown" where color _ = color (RAL :: RAL 8004) +instance StandardColor RAL "Fawn brown" where color _ = color (RAL :: RAL 8007) +instance StandardColor RAL "Olive brown" where color _ = color (RAL :: RAL 8008) +instance StandardColor RAL "Nut brown" where color _ = color (RAL :: RAL 8011) +instance StandardColor RAL "Red brown" where color _ = color (RAL :: RAL 8012) +instance StandardColor RAL "Sepia brown" where color _ = color (RAL :: RAL 8014) +instance StandardColor RAL "Chestnut brown" where color _ = color (RAL :: RAL 8015) +instance StandardColor RAL "Mahogany brown" where color _ = color (RAL :: RAL 8016) +instance StandardColor RAL "Chocolate brown" where color _ = color (RAL :: RAL 8017) +instance StandardColor RAL "Grey brown" where color _ = color (RAL :: RAL 8019) +instance StandardColor RAL "Black brown" where color _ = color (RAL :: RAL 8022) +instance StandardColor RAL "Orange brown" where color _ = color (RAL :: RAL 8023) +instance StandardColor RAL "Beige brown" where color _ = color (RAL :: RAL 8024) +instance StandardColor RAL "Pale brown" where color _ = color (RAL :: RAL 8025) +instance StandardColor RAL "Terra brown" where color _ = color (RAL :: RAL 8028) +instance StandardColor RAL "Pearl copper" where color _ = color (RAL :: RAL 8029) +instance StandardColor RAL "Cream" where color _ = color (RAL :: RAL 9001) +instance StandardColor RAL "Grey white" where color _ = color (RAL :: RAL 9002) +instance StandardColor RAL "Signal white" where color _ = color (RAL :: RAL 9003) +instance StandardColor RAL "Signal black" where color _ = color (RAL :: RAL 9004) +instance StandardColor RAL "Jet black" where color _ = color (RAL :: RAL 9005) +instance StandardColor RAL "White aluminium" where color _ = color (RAL :: RAL 9006) +instance StandardColor RAL "Grey aluminium" where color _ = color (RAL :: RAL 9007) +instance StandardColor RAL "Pure white" where color _ = color (RAL :: RAL 9010) +instance StandardColor RAL "Graphite black" where color _ = color (RAL :: RAL 9011) +instance StandardColor RAL "Traffic white" where color _ = color (RAL :: RAL 9016) +instance StandardColor RAL "Traffic black" where color _ = color (RAL :: RAL 9017) +instance StandardColor RAL "Papyrus white" where color _ = color (RAL :: RAL 9018) +instance StandardColor RAL "Pearl light grey" where color _ = color (RAL :: RAL 9022) +instance StandardColor RAL "Pearl dark grey" where color _ = pearlDarkGrey --color (RAL :: RAL 9023) diff --git a/src/Graphics/Pixel.hs b/src/Graphics/Pixel.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pixel.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Graphics.Pixel +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Pixel + ( Pixel(Pixel, PixelY, PixelRGB, PixelHSI, PixelHSL, PixelHSV, + PixelCMYK, PixelYCbCr, PixelYA, PixelRGBA, PixelHSIA, PixelHSLA, + PixelHSVA, PixelCMYKA, PixelYCbCrA) + , liftPixel + -- * Elevation + , toPixel8 + , toPixel16 + , toPixel32 + , toPixel64 + , toPixelF + , toPixelD + , module Graphics.Color.Model + ) where + +import Graphics.Color.Model +import Graphics.Pixel.Internal + +-- | Constructor for a pixel with single channel. +-- +-- @since 0.1.0 +pattern PixelY :: e -> Pixel Y e +pattern PixelY y = Pixel (ColorY y) +{-# COMPLETE PixelY #-} + +-- | Constructor for a pixel with @RGB@ color model. +-- +-- @since 0.1.0 +pattern PixelRGB :: e -> e -> e -> Pixel RGB e +pattern PixelRGB r g b = Pixel (ColorRGB r g b) +{-# COMPLETE PixelRGB #-} + +-- | Constructor for Pixel with @HSI@ color model. +-- +-- @since 0.1.0 +pattern PixelHSI :: e -> e -> e -> Pixel HSI e +pattern PixelHSI h s i = Pixel (ColorHSI h s i) +{-# COMPLETE PixelHSI #-} + +-- | Constructor for Pixel with @HSL@ color model. +-- +-- @since 0.1.0 +pattern PixelHSL :: e -> e -> e -> Pixel HSL e +pattern PixelHSL h s l = Pixel (ColorHSL h s l) +{-# COMPLETE PixelHSL #-} + +-- | Constructor for Pixel with @HSV@ color model. +-- +-- @since 0.1.0 +pattern PixelHSV :: e -> e -> e -> Pixel HSV e +pattern PixelHSV h s v = Pixel (ColorHSV h s v) +{-# COMPLETE PixelHSV #-} + +-- | Constructor for a pixel with @CMYK@ color model. +-- +-- @since 0.1.0 +pattern PixelCMYK :: e -> e -> e -> e -> Pixel CMYK e +pattern PixelCMYK c m y k = Pixel (ColorCMYK c m y k) +{-# COMPLETE PixelCMYK #-} + +-- | Constructor for a pixel with @YCbCr@ color model. +-- +-- @since 0.1.0 +pattern PixelYCbCr :: e -> e -> e -> Pixel YCbCr e +pattern PixelYCbCr y cb cr = Pixel (ColorYCbCr y cb cr) +{-# COMPLETE PixelYCbCr #-} + + +-- | Constructor for a pixel with a luminocity and transparency channels. +-- +-- @since 0.1.0 +pattern PixelYA :: e -> e -> Pixel (Alpha Y) e +pattern PixelYA y a = Pixel (Alpha (ColorY y) a) +{-# COMPLETE PixelYA #-} + +-- | Constructor for a pixel with @RGB@ color model and Alpha channel. +-- +-- @since 0.1.0 +pattern PixelRGBA :: e -> e -> e -> e -> Pixel (Alpha RGB) e +pattern PixelRGBA r g b a = Pixel (Alpha (ColorRGB r g b) a) +{-# COMPLETE PixelRGBA #-} + +-- | Constructor for a pixel with @HSI@ color model and Alpha channel. +-- +-- @since 0.1.0 +pattern PixelHSIA :: e -> e -> e -> e -> Pixel (Alpha HSI) e +pattern PixelHSIA h s i a = Pixel (Alpha (ColorHSI h s i) a) +{-# COMPLETE PixelHSIA #-} + +-- | Constructor for a pixel with @HSL@ color model and Alpha channel. +-- +-- @since 0.1.0 +pattern PixelHSLA :: e -> e -> e -> e -> Pixel (Alpha HSL) e +pattern PixelHSLA h s l a = Pixel (Alpha (ColorHSL h s l) a) +{-# COMPLETE PixelHSLA #-} + +-- | Constructor for a pixel with @HSV@ color model and Alpha channel. +-- +-- @since 0.1.0 +pattern PixelHSVA :: e -> e -> e -> e -> Pixel (Alpha HSV) e +pattern PixelHSVA h s v a = Pixel (Alpha (ColorHSV h s v) a) +{-# COMPLETE PixelHSVA #-} + + +-- | Constructor for a pixel with @CMYK@ color model and Alpha channel. +-- +-- @since 0.1.0 +pattern PixelCMYKA :: e -> e -> e -> e -> e -> Pixel (Alpha CMYK) e +pattern PixelCMYKA c m y k a = Pixel (Alpha (ColorCMYK c m y k) a) +{-# COMPLETE PixelCMYKA #-} + +-- | Constructor for a pixel with @YCbCr@ color model and Alpha channel. +-- +-- @since 0.1.0 +pattern PixelYCbCrA :: e -> e -> e -> e -> Pixel (Alpha YCbCr) e +pattern PixelYCbCrA y cb cr a = Pixel (Alpha (ColorYCbCr y cb cr) a) +{-# COMPLETE PixelYCbCrA #-} + diff --git a/src/Graphics/Pixel/ColorSpace.hs b/src/Graphics/Pixel/ColorSpace.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pixel/ColorSpace.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Pixel.ColorSpace +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Pixel.ColorSpace + ( Pixel(Pixel, PixelY, PixelXYZ, PixelRGB, PixelHSI, PixelHSL, PixelHSV, + PixelCMYK, PixelYCbCr, PixelYA, PixelXYZA, PixelRGBA, PixelHSIA, PixelHSLA, + PixelHSVA, PixelCMYKA, PixelYCbCrA) + , liftPixel + -- * Conversion + -- ** Color space + , convertPixel + , toPixelY + , toPixelXYZ + , fromPixelXYZ + , toPixelBaseSpace + , fromPixelBaseSpace + -- ** Color model + , toPixelBaseModel + , fromPixelBaseModel + -- ** Precision + , toPixel8 + , toPixel16 + , toPixel32 + , toPixel64 + , toPixelF + , toPixelD + -- * sRGB color space + , pattern PixelSRGB + , pattern PixelSRGBA + , SRGB + , D65 + -- * Adobe RGB color space + , AdobeRGB + -- * Re-export of color space + , module Graphics.Color.Space + ) where + +import Data.Coerce +import Graphics.Color.Adaptation.VonKries +import Graphics.Color.Model.Alpha +import Graphics.Color.Model.Internal +import qualified Graphics.Color.Model.RGB as CM +import Graphics.Color.Space +import Graphics.Color.Space.RGB.AdobeRGB +import Graphics.Color.Space.RGB.Alternative +import Graphics.Color.Space.RGB.SRGB +import Graphics.Pixel.Internal + +-- | Convert a pixel from one color space to any other. +-- +-- >>> :set -XTypeApplications +-- >>> px = PixelSRGB @Float 0.0 0.5 1.0 +-- >>> px +-- +-- >>> convertPixel @AdobeRGB @_ @Word8 px +-- +-- +-- @since 0.1.0 +convertPixel :: + forall cs i e cs' i' e' . (ColorSpace cs' i' e', ColorSpace cs i e) + => Pixel cs' e' + -> Pixel cs e +convertPixel = liftPixel convert +{-# INLINE convertPixel #-} + + +-- | Constructor for a pixel in @sRGB@ color space +-- +-- @since 0.1.0 +pattern PixelSRGB :: e -> e -> e -> Pixel SRGB 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 r g b a = Pixel (Alpha (SRGB (CM.ColorRGB r g b)) a) +{-# COMPLETE PixelSRGBA #-} + +-- | Constructor for a pixel with Luminocity +-- +-- @since 0.1.0 +pattern PixelY :: e -> Pixel (Y i) e +pattern PixelY y = Pixel (Y y) +{-# COMPLETE PixelY #-} + +-- | Constructor for a pixel with Luminocity and Alpha channel +-- +-- @since 0.1.0 +pattern PixelYA :: e -> e -> Pixel (Alpha (Y i)) e +pattern PixelYA y a = Pixel (Alpha (Y y) a) +{-# COMPLETE PixelYA #-} + +-- | Constructor for a pixel in @CIE1931 XYZ@ color space +-- +-- @since 0.1.0 +pattern PixelXYZ :: e -> e -> e -> Pixel (XYZ i) e +pattern PixelXYZ x y z = Pixel (XYZ (V3 x y z)) +{-# COMPLETE PixelXYZ #-} + +-- | Constructor for a pixel in @CIE1931 XYZ@ color space with Alpha channel +-- +-- @since 0.1.0 +pattern PixelXYZA :: e -> e -> e -> e -> Pixel (Alpha (XYZ i)) e +pattern PixelXYZA x y z a = Pixel (Alpha (XYZ (V3 x y z)) a) +{-# COMPLETE PixelXYZA #-} + + +-- | 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 r g b <- (coerce . unColorRGB . coerce -> V3 r g b) where + PixelRGB r g b = coerce (mkColorRGB (coerce (V3 r g b))) +{-# COMPLETE PixelRGB #-} + +-- | Constructor for a pixel in @HSI@. +-- +-- @since 0.1.0 +pattern PixelHSI :: e -> e -> e -> Pixel (HSI cs) e +pattern PixelHSI h s i = Pixel (ColorHSI h s i) +{-# COMPLETE PixelHSI #-} + + +-- | Constructor for a pixel in @HSL@. +-- +-- @since 0.1.0 +pattern PixelHSL :: e -> e -> e -> Pixel (HSL cs) e +pattern PixelHSL h s l = Pixel (ColorHSL h s l) +{-# COMPLETE PixelHSL #-} + + +-- | Constructor for a pixel in @HSV@. +-- +-- @since 0.1.0 +pattern PixelHSV :: e -> e -> e -> Pixel (HSV cs) e +pattern PixelHSV h s v = Pixel (ColorHSV h s v) +{-# COMPLETE PixelHSV #-} + +-- | Constructor for a pixel in @CMYK@. +-- +-- @since 0.1.0 +pattern PixelCMYK :: e -> e -> e -> e -> Pixel (CMYK cs) e +pattern PixelCMYK c m y k = Pixel (ColorCMYK c m y k) +{-# COMPLETE PixelCMYK #-} + + +-- | Constructor for a pixel in @YCbCr@. +-- +-- @since 0.1.0 +pattern PixelYCbCr :: e -> e -> e -> Pixel (YCbCr cs) e +pattern PixelYCbCr y cb cr = Pixel (ColorYCbCr y cb cr) +{-# COMPLETE PixelYCbCr #-} + + +-- | 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 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 #-} + + +-- | Constructor for a pixel in @HSI@ with alpha channel. +-- +-- @since 0.1.0 +pattern PixelHSIA :: e -> e -> e -> e -> Pixel (Alpha (HSI cs)) e +pattern PixelHSIA h s i a = Pixel (ColorHSIA h s i a) +{-# COMPLETE PixelHSIA #-} + +-- | Constructor for a pixel in @HSL@ with alpha channel. +-- +-- @since 0.1.0 +pattern PixelHSLA :: e -> e -> e -> e -> Pixel (Alpha (HSL cs)) e +pattern PixelHSLA h s l a = Pixel (ColorHSLA h s l a) +{-# COMPLETE PixelHSLA #-} + + +-- | Constructor for a pixel in @HSV@ with alpha channel. +-- +-- @since 0.1.0 +pattern PixelHSVA :: e -> e -> e -> e -> Pixel (Alpha (HSV cs)) e +pattern PixelHSVA h s v a = Pixel (ColorHSVA h s v a) +{-# COMPLETE PixelHSVA #-} + + +-- | Constructor for a pixel in @CMYK@ with alpha channel. +-- +-- @since 0.1.0 +pattern PixelCMYKA :: e -> e -> e -> e -> e -> Pixel (Alpha (CMYK cs)) e +pattern PixelCMYKA c m y k a = Pixel (ColorCMYKA c m y k a) +{-# COMPLETE PixelCMYKA #-} + + +-- | Constructor for a pixel in @YCbCr@ with alpha channel. +-- +-- @since 0.1.0 +pattern PixelYCbCrA :: e -> e -> e -> e -> Pixel (Alpha (YCbCr cs)) e +pattern PixelYCbCrA y cb cr a = Pixel (ColorYCbCrA y cb cr a) +{-# COMPLETE PixelYCbCrA #-} + +-- | Compute luminance pixel of a pixel color +-- +-- @since 0.1.0 +toPixelY :: ColorSpace cs i e => Pixel cs e -> Pixel (Y i) e +toPixelY = liftPixel (fmap fromDouble . luminance) +{-# INLINE toPixelY #-} + +-- | Convert to CIE1931 XYZ color space, with the same illuminant as the original. +-- +-- @since 0.1.0 +toPixelXYZ :: (ColorSpace cs i e, Elevator a, RealFloat a) => Pixel cs e -> Pixel (XYZ i) a +toPixelXYZ = liftPixel toColorXYZ +{-# INLINE toPixelXYZ #-} + + +-- | Convert from CIE1931 XYZ color space, with the same illuminant as the target color +-- space. +-- +-- @since 0.1.0 +fromPixelXYZ :: (ColorSpace cs i e, Elevator a, RealFloat a) => Pixel (XYZ i) a -> Pixel cs e +fromPixelXYZ = liftPixel fromColorXYZ +{-# INLINE fromPixelXYZ #-} + + + +-- Color Space conversions + +-- | Drop all color space information and only keep the values encoded in the fitting +-- color model, which the color space is backed by. +-- +-- @since 0.1.0 +toPixelBaseModel :: ColorSpace cs i e => Pixel cs e -> Pixel (BaseModel cs) e +toPixelBaseModel = liftPixel toBaseModel +{-# INLINE toPixelBaseModel #-} + +-- | Promote a pixel without color space information to a color space that is backed by +-- the fitting color model +-- +-- @since 0.1.0 +fromPixelBaseModel :: ColorSpace cs i e => Pixel (BaseModel cs) e -> Pixel cs e +fromPixelBaseModel = liftPixel fromBaseModel +{-# INLINE fromPixelBaseModel #-} + +-- | Convert pixel in an alternative representation of color space, to its base color +-- space. Example from CMYK to SRGB +-- +-- @since 0.1.0 +toPixelBaseSpace :: + (ColorSpace cs i e, bcs ~ BaseSpace cs, ColorSpace bcs i e) => Pixel cs e -> Pixel bcs e +toPixelBaseSpace = liftPixel toBaseSpace +{-# INLINE toPixelBaseSpace #-} + +-- | Covert a color space of a pixel into it's alternative representation. Example AdobeRGB to HSI. +-- +-- @since 0.1.0 +fromPixelBaseSpace :: + (ColorSpace cs i e, bcs ~ BaseSpace cs, ColorSpace bcs i e) => Pixel bcs e -> Pixel cs e +fromPixelBaseSpace = liftPixel fromBaseSpace +{-# INLINE fromPixelBaseSpace #-} + + +-- -- | Constructor for a pixel in @sRGB@ color space with 8-bits per channel +-- pattern PixelRGB8 :: Word8 -> Word8 -> Word8 -> Pixel SRGB Word8 +-- pattern PixelRGB8 r g b = Pixel (SRGB (CM.ColorRGB r g b)) +-- {-# COMPLETE PixelRGB8 #-} + +-- -- | Constructor for a pixel in @sRGB@ color space with 16-bits per channel +-- pattern PixelRGB16 :: Word16 -> Word16 -> Word16 -> Pixel SRGB Word16 +-- pattern PixelRGB16 r g b = Pixel (SRGB (CM.ColorRGB r g b)) +-- {-# COMPLETE PixelRGB16 #-} + +-- -- | Constructor for a pixel in @sRGB@ color space with 32-bits per channel +-- pattern PixelRGB32 :: Word32 -> Word32 -> Word32 -> Pixel SRGB Word32 +-- pattern PixelRGB32 r g b = Pixel (SRGB (CM.ColorRGB r g b)) +-- {-# COMPLETE PixelRGB32 #-} + +-- -- | Constructor for a pixel in @sRGB@ color space with 64-bits per channel +-- pattern PixelRGB64 :: Word64 -> Word64 -> Word64 -> Pixel SRGB Word64 +-- pattern PixelRGB64 r g b = Pixel (SRGB (CM.ColorRGB r g b)) +-- {-# COMPLETE PixelRGB64 #-} + +-- -- | Constructor for a pixel in @sRGB@ color space with 32-bit floating point value per channel +-- pattern PixelRGBF :: Float -> Float -> Float -> Pixel SRGB Float +-- pattern PixelRGBF r g b = Pixel (SRGB (CM.ColorRGB r g b)) +-- {-# COMPLETE PixelRGBF #-} + +-- -- | Constructor for a pixel in @sRGB@ color space with 32-bit floating point value per channel +-- pattern PixelRGBD :: Double -> Double -> Double -> Pixel SRGB Double +-- pattern PixelRGBD r g b = Pixel (SRGB (CM.ColorRGB r g b)) +-- {-# COMPLETE PixelRGBD #-} diff --git a/src/Graphics/Pixel/Internal.hs b/src/Graphics/Pixel/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Pixel/Internal.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Graphics.Pixel.Internal +-- Copyright : (c) Alexey Kuleshevich 2019-2020 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Pixel.Internal + ( Pixel(..) + , liftPixel + , toPixel8 + , toPixel16 + , toPixel32 + , toPixel64 + , toPixelF + , toPixelD + ) where + +import Data.Coerce +import Control.DeepSeq (NFData) +import Graphics.Color.Model.Internal +import Control.Monad (liftM) +import Foreign.Storable +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as VM +import qualified Data.Vector.Unboxed as VU + +-- | 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. +-- +-- @since 0.1.0 +newtype Pixel cs e = Pixel + { pixelColor :: Color cs e + } + +deriving instance Eq (Color cs e) => Eq (Pixel cs e) +deriving instance Ord (Color cs e) => Ord (Pixel cs e) +deriving instance Num (Color cs e) => Num (Pixel cs e) +deriving instance Bounded (Color cs e) => Bounded (Pixel cs e) +deriving instance NFData (Color cs e) => NFData (Pixel cs e) +deriving instance Floating (Color cs e) => Floating (Pixel cs e) +deriving instance Fractional (Color cs e) => Fractional (Pixel cs e) +deriving instance Functor (Color cs) => Functor (Pixel cs) +deriving instance Applicative (Color cs) => Applicative (Pixel cs) +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) +instance Show (Color cs e) => Show (Pixel cs e) where + show = show . pixelColor + +-- | Unboxing of a `Pixel`. +instance ColorModel cs e => VU.Unbox (Pixel cs e) + +newtype instance VU.MVector s (Pixel cs e) = MV_Pixel (VU.MVector s (Components cs e)) + +instance ColorModel cs e => VM.MVector VU.MVector (Pixel cs e) where + basicLength (MV_Pixel mvec) = VM.basicLength mvec + {-# INLINE basicLength #-} + basicUnsafeSlice idx len (MV_Pixel mvec) = MV_Pixel (VM.basicUnsafeSlice idx len mvec) + {-# INLINE basicUnsafeSlice #-} + basicOverlaps (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicOverlaps mvec mvec' + {-# INLINE basicOverlaps #-} + basicUnsafeNew len = MV_Pixel `liftM` VM.basicUnsafeNew len + {-# INLINE basicUnsafeNew #-} + basicUnsafeReplicate len val = + MV_Pixel `liftM` VM.basicUnsafeReplicate len (toComponents (coerce val)) + {-# INLINE basicUnsafeReplicate #-} + basicUnsafeRead (MV_Pixel mvec) idx = (coerce . fromComponents) `liftM` VM.basicUnsafeRead mvec idx + {-# INLINE basicUnsafeRead #-} + basicUnsafeWrite (MV_Pixel mvec) idx val = VM.basicUnsafeWrite mvec idx (toComponents (coerce val)) + {-# INLINE basicUnsafeWrite #-} + basicClear (MV_Pixel mvec) = VM.basicClear mvec + {-# INLINE basicClear #-} + basicSet (MV_Pixel mvec) val = VM.basicSet mvec (toComponents (coerce val)) + {-# INLINE basicSet #-} + basicUnsafeCopy (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeCopy mvec mvec' + {-# INLINE basicUnsafeCopy #-} + basicUnsafeMove (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeMove mvec mvec' + {-# INLINE basicUnsafeMove #-} + basicUnsafeGrow (MV_Pixel mvec) len = MV_Pixel `liftM` VM.basicUnsafeGrow mvec len + {-# INLINE basicUnsafeGrow #-} +#if MIN_VERSION_vector(0,11,0) + basicInitialize (MV_Pixel mvec) = VM.basicInitialize mvec + {-# INLINE basicInitialize #-} +#endif + + +newtype instance VU.Vector (Pixel cs e) = V_Pixel (VU.Vector (Components cs e)) + +instance (ColorModel cs e) => V.Vector VU.Vector (Pixel cs e) where + basicUnsafeFreeze (MV_Pixel mvec) = V_Pixel `liftM` V.basicUnsafeFreeze mvec + {-# INLINE basicUnsafeFreeze #-} + basicUnsafeThaw (V_Pixel vec) = MV_Pixel `liftM` V.basicUnsafeThaw vec + {-# INLINE basicUnsafeThaw #-} + basicLength (V_Pixel vec) = V.basicLength vec + {-# INLINE basicLength #-} + basicUnsafeSlice idx len (V_Pixel vec) = V_Pixel (V.basicUnsafeSlice idx len vec) + {-# INLINE basicUnsafeSlice #-} + basicUnsafeIndexM (V_Pixel vec) idx = (coerce . fromComponents) `liftM` V.basicUnsafeIndexM vec idx + {-# INLINE basicUnsafeIndexM #-} + basicUnsafeCopy (MV_Pixel mvec) (V_Pixel vec) = V.basicUnsafeCopy mvec vec + {-# INLINE basicUnsafeCopy #-} + elemseq (V_Pixel vec) val = V.elemseq vec (toComponents (coerce val)) + {-# INLINE elemseq #-} + +-- | Apply a function to `Pixel`'s `Color` +-- +-- @since 0.1.0 +liftPixel :: (Color cs e -> Color cs' e') -> Pixel cs e -> Pixel cs' e' +liftPixel f = coerce . f . coerce +{-# INLINE liftPixel #-} + + + +-- Elevation + +-- | Convert all channels of a pixel to 8bits each, while doing appropriate scaling. See +-- `Elevator`. +-- +-- @since 0.1.0 +toPixel8 :: ColorModel cs e => Pixel cs e -> Pixel cs Word8 +toPixel8 = liftPixel (fmap toWord8) +{-# INLINE toPixel8 #-} + +-- | Convert all channels of a pixel to 16bits each, while appropriate scaling. See +-- `Elevator`. +-- +-- @since 0.1.0 +toPixel16 :: ColorModel cs e => Pixel cs e -> Pixel cs Word16 +toPixel16 = liftPixel (fmap toWord16) +{-# INLINE toPixel16 #-} + + +-- | Convert all channels of a pixel to 32bits each, while doing appropriate scaling. See +-- `Elevator`. +-- +-- @since 0.1.0 +toPixel32 :: ColorModel cs e => Pixel cs e -> Pixel cs Word32 +toPixel32 = liftPixel (fmap toWord32) +{-# INLINE toPixel32 #-} + + +-- | Convert all channels of a pixel to 64bits each, while doing appropriate scaling. See +-- `Elevator`. +-- +-- @since 0.1.0 +toPixel64 :: ColorModel cs e => Pixel cs e -> Pixel cs Word64 +toPixel64 = liftPixel (fmap toWord64) +{-# INLINE toPixel64 #-} + + +-- | Convert all channels of a pixel to 32bit floating point numers each, while doing +-- appropriate scaling. See `Elevator`. +-- +-- @since 0.1.0 +toPixelF :: ColorModel cs e => Pixel cs e -> Pixel cs Float +toPixelF = liftPixel (fmap toFloat) +{-# INLINE toPixelF #-} + +-- | Convert all channels of a pixel to 64bit floating point numers each, while doing +-- appropriate scaling. See `Elevator`. +-- +-- @since 0.1.0 +toPixelD :: ColorModel cs e => Pixel cs e -> Pixel cs Double +toPixelD = liftPixel (fmap toDouble) +{-# INLINE toPixelD #-} diff --git a/tests/Graphics/Color/Model/CMYKSpec.hs b/tests/Graphics/Color/Model/CMYKSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Model/CMYKSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Model.CMYKSpec (spec) where + +import Graphics.Color.Model +import Graphics.Color.Model.Common +import Graphics.Color.Model.RGBSpec () + +instance (Elevator e, Random e) => Arbitrary (Color CMYK e) where + arbitrary = + ColorCMYK <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator <*> + arbitraryElevator + +spec :: Spec +spec = + describe "CMYK" $ do + colorModelSpec @CMYK @Word "CMYK" + prop "rgb2cmyk . cmyk2rgb" $ \(rgb :: Color RGB Double) -> + rgb `epsilonEqColor` cmyk2rgb (rgb2cmyk rgb) diff --git a/tests/Graphics/Color/Model/Common.hs b/tests/Graphics/Color/Model/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Model/Common.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Model.Common + ( colorModelSpec + , toFromComponentsSpec + , izipWithM_ + , matchListsWith + , expectSameLength + , epsilonExpect + , epsilonColorExpect + , epsilonColorIxSpec + , epsilonEq + , epsilonEqColor + , epsilonEqColorTol + , epsilonEqColorTolIx + , arbitraryElevator + , module Test.Hspec + , module Test.Hspec.QuickCheck + , module Test.QuickCheck + , module System.Random + ) where + +import Control.Applicative +import Data.Proxy +import Data.Foldable as F +import Graphics.Color.Model +import System.Random +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.HUnit (assertBool) +import Test.QuickCheck +import Control.Monad + +izipWithM_ :: Applicative m => (Int -> a -> b -> m c) -> [a] -> [b] -> m () +izipWithM_ f xs = zipWithM_ (uncurry f) (zip [0..] xs) + + +-- | Match to lists exactly element-by-element with an expectation. +matchListsWith :: (a -> b -> Expectation) -> [a] -> [b] -> Expectation +matchListsWith f xs ys = do + expectSameLength xs ys + zipWithM_ f xs ys + +expectSameLength :: Foldable t => t a1 -> t a2 -> IO () +expectSameLength xs ys = + unless (length xs == length ys) $ + expectationFailure $ "List lengths mismatch: " ++ show (length xs) ++ "/=" ++ show (length ys) + + +arbitraryElevator :: (Elevator e, Random e) => Gen e +arbitraryElevator = choose (minValue, maxValue) + +epsilonExpect :: + (HasCallStack, Show a, RealFloat a) + => a -- ^ Epsilon, a maximum tolerated error. Sign is ignored. + -> a -- ^ Expected result. + -> a -- ^ Tested value. + -> Expectation +epsilonExpect epsilon x y + | isNaN x = y `shouldSatisfy` isNaN + | x == y = pure () + | otherwise = + assertBool (concat [show x, " /= ", show y, "\nTolerance: ", show diff, " > ", show n]) (diff <= n) + where + (absx, absy) = (abs x, abs y) + n = epsilon * (1 + max absx absy) + diff = abs (y - x) + +epsilonColorExpect :: + (HasCallStack, ColorModel cs e, RealFloat e) => e -> Color cs e -> Color cs e -> Expectation +epsilonColorExpect epsilon x y = zipWithM_ (epsilonExpect epsilon) (F.toList x) (F.toList y) + +epsilonColorIxSpec :: + (HasCallStack, ColorModel cs e, RealFloat e) + => e + -> Int + -> Color cs e + -> Color cs e + -> Spec +epsilonColorIxSpec epsilon ix x y = + it ("Index: " ++ show ix) $ zipWithM_ (epsilonExpect epsilon) (F.toList x) (F.toList y) + + +epsilonEq :: + (Show a, RealFloat a) + => a -- ^ Epsilon, a maximum tolerated error. Sign is ignored. + -> a -- ^ Expected result. + -> a -- ^ Tested value. + -> Property +epsilonEq epsilon x y = once $ epsilonExpect epsilon x y + +epsilonEqColor :: (ColorModel cs e, RealFloat e) => Color cs e -> Color cs e -> Property +epsilonEqColor = epsilonEqColorTol epsilon + where + epsilon = 1e-11 + +epsilonEqColorTol :: (ColorModel cs e, RealFloat e) => e -> Color cs e -> Color cs e -> Property +epsilonEqColorTol epsilon x y = conjoin $ F.toList $ liftA2 (epsilonEq epsilon) x y + +-- | Same as `epsilonEqColorTol` but with indexed counterexample. +epsilonEqColorTolIx :: + (ColorModel cs e, RealFloat e) => e -> Int -> Color cs e -> Color cs e -> Property +epsilonEqColorTolIx tol ix expected actual = + counterexample ("Index: " ++ show ix) $ epsilonEqColorTol tol expected actual + +prop_ToFromComponents :: + forall cs e. ColorModel cs e + => Color cs e + -> Property +prop_ToFromComponents px = px === fromComponents (toComponents px) + +toFromComponentsSpec :: forall cs e . (ColorModel cs e, Arbitrary (Color cs e)) => Spec +toFromComponentsSpec = prop "fromComponents . toComponents" $ prop_ToFromComponents @cs @e + + +colorModelSpec :: forall cs e . (ColorModel cs e, Arbitrary (Color cs e)) => String -> Spec +colorModelSpec name = + describe "ColorModel" $ do + toFromComponentsSpec @cs @e + it "name" $ showsColorModelName (Proxy :: Proxy (Color cs e)) "" `shouldStartWith` name diff --git a/tests/Graphics/Color/Model/HSISpec.hs b/tests/Graphics/Color/Model/HSISpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Model/HSISpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Model.HSISpec (spec) where + +import Graphics.Color.Model +import Graphics.Color.Model.Common +import Graphics.Color.Model.RGBSpec (rgbs) + +instance (Elevator e, Random e) => Arbitrary (Color HSI e) where + arbitrary = ColorHSI <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + +spec :: Spec +spec = + describe "HSI" $ do + colorModelSpec @HSI @Word "HSI" + prop "rgb2hsi . hsi2rgb" $ \(rgb :: Color RGB Double) -> + rgb `epsilonEqColor` hsi2rgb (rgb2hsi rgb) + prop "hsi2rgb . rgb2hsi" $ \(hsi :: Color HSI Double) -> + hsi `epsilonEqColor` rgb2hsi (hsi2rgb hsi) + describe "samples" $ do + let tol = 1e-3 + describe "rgb2hsi" $ izipWithM_ (epsilonColorIxSpec tol) hsis (rgb2hsi <$> rgbs) + describe "hsi2rgb" $ izipWithM_ (epsilonColorIxSpec tol) rgbs (hsi2rgb <$> hsis) + + +hsis :: [Color HSI Double] +hsis = + [ ColorH360SI 0 0 1 + , ColorH360SI 0 0 0.5 + , ColorH360SI 0 0 0 + , ColorH360SI 0.0 1 0.333 + , ColorH360SI 60.0 1 0.5 + , ColorH360SI 120.0 1 0.167 + , ColorH360SI 180.0 0.4 0.833 + , ColorH360SI 240.0 0.25 0.667 + , ColorH360SI 300.0 0.571 0.583 + , ColorH360SI 61.5 0.699 0.471 + , ColorH360SI 250.0 0.756 0.426 + , ColorH360SI 133.8 0.667 0.349 + , ColorH360SI 50.5 0.911 0.593 + , ColorH360SI 284.8 0.686 0.596 + , ColorH360SI 13.2 0.446 0.57 + , ColorH360SI 57.4 0.363 0.835 + , ColorH360SI 163.4 0.8 0.495 + , ColorH360SI 247.3 0.533 0.319 + , ColorH360SI 240.4 0.135 0.57 + ] diff --git a/tests/Graphics/Color/Model/HSLSpec.hs b/tests/Graphics/Color/Model/HSLSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Model/HSLSpec.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Model.HSLSpec (spec) where + +import Graphics.Color.Model +import Graphics.Color.Model.Common +import Graphics.Color.Model.RGBSpec (rgbs) + +instance (Elevator e, Random e) => Arbitrary (Color HSL e) where + arbitrary = ColorHSL <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + +spec :: Spec +spec = + describe "HSL" $ do + colorModelSpec @HSL @Word "HSL" + prop "rgb2hsl . hsl2rgb" $ \(rgb :: Color RGB Double) -> + rgb `epsilonEqColor` hsl2rgb (rgb2hsl rgb) + prop "hsl2rgb . rgb2hsl" $ \(hsl :: Color HSL Double) -> + hsl `epsilonEqColor` rgb2hsl (hsl2rgb hsl) + describe "samples" $ do + let tol = 2e-3 + describe "rgb2hsl" $ izipWithM_ (epsilonColorIxSpec tol) hsls (rgb2hsl <$> rgbs) + describe "hsl2rgb" $ izipWithM_ (epsilonColorIxSpec tol) rgbs (hsl2rgb <$> hsls) + + +hsls :: [Color HSL Double] +hsls = + [ ColorH360SL (0 / 0) 0 1 + , ColorH360SL (0 / 0) 0 0.5 + , ColorH360SL (0 / 0) 0 0 + , ColorH360SL 0.0 1 0.5 + , ColorH360SL 60.0 1 0.375 + , ColorH360SL 120.0 1 0.25 + , ColorH360SL 180.0 1 0.75 + , ColorH360SL 240.0 1 0.75 + , ColorH360SL 300.0 0.5 0.5 + , ColorH360SL 61.8 0.638 0.393 + , ColorH360SL 251.1 0.832 0.511 + , ColorH360SL 134.9 0.707 0.396 + , ColorH360SL 49.5 0.893 0.498 + , ColorH360SL 283.7 0.775 0.543 + , ColorH360SL 14.3 0.817 0.624 + , ColorH360SL 56.9 0.991 0.765 + , ColorH360SL 162.4 0.779 0.447 + , ColorH360SL 248.3 0.601 0.373 + , ColorH360SL 240.5 0.29 0.608 + ] diff --git a/tests/Graphics/Color/Model/HSVSpec.hs b/tests/Graphics/Color/Model/HSVSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Model/HSVSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Model.HSVSpec (spec) where + +import Graphics.Color.Model +import Graphics.Color.Model.Common +import Graphics.Color.Model.RGBSpec (rgbs) + +instance (Elevator e, Random e) => Arbitrary (Color HSV e) where + arbitrary = ColorHSV <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + +spec :: Spec +spec = + describe "HSV" $ do + colorModelSpec @HSV @Word "HSV" + prop "rgb2hsv . hsv2rgb" $ \(rgb :: Color RGB Double) -> + rgb `epsilonEqColor` hsv2rgb (rgb2hsv rgb) + prop "hsv2rgb . rgb2hsv" $ \(hsv :: Color HSV Double) -> + hsv `epsilonEqColor` rgb2hsv (hsv2rgb hsv) + describe "samples" $ do + let tol = 1e-3 + describe "rgb2hsv" $ izipWithM_ (epsilonColorIxSpec tol) hsvs (rgb2hsv <$> rgbs) + describe "hsv2rgb" $ izipWithM_ (epsilonColorIxSpec tol) rgbs (hsv2rgb <$> hsvs) + + +hsvs :: [Color HSV Double] +hsvs = + [ ColorH360SV (0/0) 0 1 + , ColorH360SV (0/0) 0 0.5 + , ColorH360SV (0/0) 0 0 + , ColorH360SV 0.0 1 1 + , ColorH360SV 60.0 1 0.75 + , ColorH360SV 120.0 1 0.5 + , ColorH360SV 180.0 0.5 1 + , ColorH360SV 240.0 0.5 1 + , ColorH360SV 300.0 0.667 0.75 + , ColorH360SV 61.8 0.779 0.643 + , ColorH360SV 251.1 0.887 0.918 + , ColorH360SV 134.9 0.828 0.675 + , ColorH360SV 49.5 0.944 0.941 + , ColorH360SV 283.7 0.792 0.897 + , ColorH360SV 14.3 0.661 0.931 + , ColorH360SV 56.9 0.467 0.998 + , ColorH360SV 162.4 0.875 0.795 + , ColorH360SV 248.3 0.75 0.597 + , ColorH360SV 240.5 0.316 0.721 + ] diff --git a/tests/Graphics/Color/Model/RGBSpec.hs b/tests/Graphics/Color/Model/RGBSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Model/RGBSpec.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Model.RGBSpec (spec, rgbs) where + +import Graphics.Color.Model +import Graphics.Color.Model.Common + +instance (Elevator e, Random e) => Arbitrary (Color RGB e) where + arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + + +spec :: Spec +spec = + describe "RGB" $ + colorModelSpec @RGB @Word "RGB" + + +rgbs :: [Color RGB Double] +rgbs = + [ ColorRGB 1 1 1 + , ColorRGB 0.5 0.5 0.5 + , ColorRGB 0 0 0 + , ColorRGB 1 0 0 + , ColorRGB 0.75 0.75 0 + , ColorRGB 0 0.5 0 + , ColorRGB 0.5 1 1 + , ColorRGB 0.5 0.5 1 + , ColorRGB 0.75 0.25 0.75 + , ColorRGB 0.628 0.643 0.142 + , ColorRGB 0.255 0.104 0.918 + , ColorRGB 0.116 0.675 0.255 + , ColorRGB 0.941 0.785 0.053 + , ColorRGB 0.704 0.187 0.897 + , ColorRGB 0.931 0.463 0.316 + , ColorRGB 0.998 0.974 0.532 + , ColorRGB 0.099 0.795 0.591 + , ColorRGB 0.211 0.149 0.597 + , ColorRGB 0.495 0.493 0.721 + ] diff --git a/tests/Graphics/Color/Space/CIE1931/IlluminantSpec.hs b/tests/Graphics/Color/Space/CIE1931/IlluminantSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Space/CIE1931/IlluminantSpec.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Graphics.Color.Space.CIE1931.IlluminantSpec (spec) where + +import Data.Proxy +import Graphics.Color.Space.Common +import Graphics.Color.Illuminant.CIE1931 as CIE1931 +import qualified Data.Colour.CIE as Colour +import qualified Data.Colour.CIE.Illuminant as Colour + +shouldMatchApprox :: + forall i. Illuminant (i :: k) + => (Double, Double, Double) + -> WhitePoint i Double + -> Spec +shouldMatchApprox (x, y, _) wp = + let (x', y', z') = (xWhitePoint wp, yWhitePoint wp, zWhitePoint wp) + eps = 1e-3 -- This is rather unfortunate, but it seems that "colour" package authors + -- decided to go with the values from wikipedia, rather than from the + -- document created by CIE: Technical Report: Colorimetry, 3rd edition + in prop (showsType (Proxy :: Proxy (WhitePoint i Double)) "") $ once $ + epsilonEq eps x x' .&&. epsilonEq eps y y' .&&. epsilonEq 1e-12 1 (x' + y' + z') + +spec :: Spec +spec = + describe "Illuminants" $ + describe "ColourMatch" $ do + Colour.chromaCoords Colour.a `shouldMatchApprox` (whitePoint :: WhitePoint 'A Double) + Colour.chromaCoords Colour.b `shouldMatchApprox` (whitePoint :: WhitePoint 'B Double) + Colour.chromaCoords Colour.c `shouldMatchApprox` (whitePoint :: WhitePoint 'C Double) + Colour.chromaCoords Colour.d50 `shouldMatchApprox` (whitePoint :: WhitePoint 'D50 Double) + Colour.chromaCoords Colour.d55 `shouldMatchApprox` (whitePoint :: WhitePoint 'D55 Double) + Colour.chromaCoords Colour.d65 `shouldMatchApprox` (whitePoint :: WhitePoint 'CIE1931.D65 Double) + Colour.chromaCoords Colour.d75 `shouldMatchApprox` (whitePoint :: WhitePoint 'D75 Double) + Colour.chromaCoords Colour.e `shouldMatchApprox` (whitePoint :: WhitePoint 'E Double) + Colour.chromaCoords Colour.f1 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL1 Double) + Colour.chromaCoords Colour.f2 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL2 Double) + Colour.chromaCoords Colour.f3 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL3 Double) + Colour.chromaCoords Colour.f4 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL4 Double) + Colour.chromaCoords Colour.f5 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL5 Double) + Colour.chromaCoords Colour.f6 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL6 Double) + Colour.chromaCoords Colour.f7 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL7 Double) + Colour.chromaCoords Colour.f8 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL8 Double) + Colour.chromaCoords Colour.f9 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL9 Double) + Colour.chromaCoords Colour.f10 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL10 Double) + Colour.chromaCoords Colour.f11 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL11 Double) + Colour.chromaCoords Colour.f12 `shouldMatchApprox` (whitePoint :: WhitePoint 'FL12 Double) diff --git a/tests/Graphics/Color/Space/CIE1976/LABSpec.hs b/tests/Graphics/Color/Space/CIE1976/LABSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Space/CIE1976/LABSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Space.CIE1976.LABSpec (spec) where + +import Graphics.Color.Space.Common +import Graphics.Color.Illuminant.CIE1931 as I2 +import Graphics.Color.Space.CIE1976.LAB + +instance (Elevator e, Random e, Illuminant i) => Arbitrary (Color (LAB (i :: k)) e) where + arbitrary = ColorLAB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + + +spec :: Spec +spec = describe "LAB" $ do + colorModelSpec @(LAB 'D65) @Word "LAB" + prop "toFromColorXYZ" (prop_toFromColorXYZ :: Color (LAB 'D65) Double -> Property) + prop "toFromColorSpace" (prop_toFromColorSpace :: Color (LAB 'D65) Double -> Property) + diff --git a/tests/Graphics/Color/Space/Common.hs b/tests/Graphics/Color/Space/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Space/Common.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Graphics.Color.Space.Common + ( module Graphics.Color.Space + , module Graphics.Color.Model.Common + , prop_toFromColorXYZ + , prop_toFromLenientColorXYZ + , prop_toFromColorSpace + ) where + +import Graphics.Color.Space +import Graphics.Color.Model.Common + + +prop_toFromColorXYZ :: + forall cs i e. (ColorSpace cs (i :: k) e, RealFloat e) + => Color cs e + -> Property +prop_toFromColorXYZ px = px `epsilonEqColor` fromColorXYZ (toColorXYZ px :: Color (XYZ i) Double) + + +-- For RGB standards, that have matrices rounded to 4 digits after the decimal point +prop_toFromLenientColorXYZ :: + forall cs i e. (ColorSpace cs i e, RealFloat e) + => e + -> Color cs e + -> Property +prop_toFromLenientColorXYZ epsilon px = + epsilonEqColorTol epsilon px (fromColorXYZ (toColorXYZ px :: Color (XYZ i) Double)) + + +prop_toFromColorSpace :: + forall cs i e. (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, RealFloat e) + => Color cs e + -> Property +prop_toFromColorSpace px = px `epsilonEqColor` fromBaseSpace (toBaseSpace px) + diff --git a/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs b/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Space.RGB.Derived.SRGBSpec (spec) where + +import Graphics.Color.Space.Common +import Graphics.Color.Illuminant.CIE1931 +import Graphics.Color.Space.RGB.Derived.SRGB + +instance (Elevator e, Random e, Illuminant i) => Arbitrary (Color (SRGB (i :: k)) e) where + arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + + +spec :: Spec +spec = describe "SRGB" $ do + colorModelSpec @(SRGB 'D65) @Word "SRGB" + prop "toFromColorXYZ" (prop_toFromColorXYZ :: Color (SRGB 'D65) Double -> Property) + prop "toFromColorSpace" (prop_toFromColorSpace :: Color (SRGB 'D65) Double -> Property) diff --git a/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs b/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Space.RGB.ITU.Rec709Spec (spec) where + +import Graphics.Color.Space.Common +import Graphics.Color.Space.RGB.ITU.Rec709 + +instance (Elevator e, Random e) => Arbitrary (Color BT709 e) where + arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + + +spec :: Spec +spec = describe "Rec709" $ do + colorModelSpec @BT709 @Word "BT709" + -- Roundrtrip is not always very accurate, eg: 8.115324539550295e-2 /= 8.140132075907752e-2 + prop "toFromColorXYZ (lenient)" $ + prop_toFromLenientColorXYZ @BT709 @_ @Double 5e-4 + prop "toFromColorSpace" $ prop_toFromColorSpace @BT709 @_ @Double diff --git a/tests/Graphics/Color/Space/RGB/SRGBSpec.hs b/tests/Graphics/Color/Space/RGB/SRGBSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Space/RGB/SRGBSpec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Space.RGB.SRGBSpec (spec, arbitraryElevator) where + +import Graphics.Color.Space.Common +import Graphics.Color.Space.RGB.SRGB + +instance (Elevator e, Random e) => Arbitrary (Color SRGB e) where + arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + + +spec :: Spec +spec = describe "SRGB" $ do + colorModelSpec @SRGB @Word "SRGB" + prop "toFromColorXYZ (lenient)" $ prop_toFromLenientColorXYZ @SRGB @_ @Double 0.001 + prop "toFromColorSpace" $ prop_toFromColorSpace @SRGB @_ @Double diff --git a/tests/Graphics/Color/Space/YUV/YCbCrSpec.hs b/tests/Graphics/Color/Space/YUV/YCbCrSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Space/YUV/YCbCrSpec.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.Space.YUV.YCbCrSpec (spec) where + +import Graphics.Color.Space.Common +-- import Graphics.Color.Space.YCbCr +-- import Graphics.Color.Space.RGBSpec () + +-- instance (Elevator e, Random e) => Arbitrary (Color YCbCr e) where +-- arbitrary = ColorYCbCr <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator + +spec :: Spec +spec = pure () + -- describe "YCbCr" $ do + -- colorModelSpec @YCbCr @Word + -- it "rgb2ycbcr . ycbcr2rgb" $ + -- property $ \rgb -> epsilonEqColorTol (1e-5 :: Double) rgb (ycbcr2rgb (rgb2ycbcr rgb)) diff --git a/tests/Graphics/Color/Standard/RALSpec.hs b/tests/Graphics/Color/Standard/RALSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/Standard/RALSpec.hs @@ -0,0 +1,1616 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +module Graphics.Color.Standard.RALSpec (spec) where + +import Control.Monad (zipWithM_, unless, when) +import Data.Kind +import GHC.TypeLits +import Graphics.Color.Model.Common hiding ((.&.)) +import Graphics.Color.Space +import Graphics.Color.Space.RGB +import Graphics.Color.Standard.RAL as RAL +import Graphics.Color.Space.CIE1976.LAB +import Data.Bits + + +spec :: Spec +spec = do + describe "RAL" $ do + let ralsLAB = [(n, c) | (n, c, _) <- ralColors] :: [(String, Color (LAB D50) Float)] + ralColors' :: ColorSpace cs i e => [(String, Color cs e)] + ralColors' = [(n, c) | (n, c, d) <- ralColors, not d] + matchColor (ename, expected) (rname, received) = + unless (received == expected) $ + expectationFailure $ + concat + [ "Recieved color: " + , rname + , " did not match the one produced by matching function: '" + , ename + , "': " + , show received + , " /= " + , show expected + ] + specMatchLists pendingNames expect expectedColors receivedColors = do + it "Lists have the same length" $ expectSameLength expectedColors receivedColors + let mkTest expected (rname, received) = + it rname $ do + when (rname `elem` pendingNames) $ pendingWith "Some discrepancy" + (expect received expected) + zipWithM_ mkTest expectedColors receivedColors + it "Color code matches" $ matchListsWith matchColor ralsLAB (toColorRAL ralColorCodes) + it "Color name matches" $ matchListsWith matchColor ralsLAB (toColorRAL ralColorNames) + let (srgbs, hsls, _cmyks) = unzip3 ralAlternatives + describe "Matches sRGB" $ + specMatchLists ["luminousBrightOrange", "pastelGreen"] shouldBe srgbs ralColors' + xdescribe "Matches HSL" $ specMatchLists [] shouldBe hsls ralColors' + + + +data HList (as :: [Type]) where + HNil :: HList '[] + (:>) :: a -> HList as -> HList (a ': as) + +infixr 5 :> + +class FromColorsRAL (xs :: [Type]) where + toColorRAL :: ColorSpace cs i e => HList xs -> [(String, Color cs e)] + +instance FromColorsRAL '[] where + toColorRAL _ = [] + +instance (KnownNat code, StandardColor RAL code, FromColorsRAL xs) => + FromColorsRAL (RAL (code :: Nat) ': xs) where + toColorRAL (c :> cs) = (show c, color c) : toColorRAL cs + +instance (KnownSymbol name, StandardColor RAL name, FromColorsRAL xs) => + FromColorsRAL (RAL (name :: Symbol) ': xs) where + toColorRAL (c :> cs) = (show c, color c) : toColorRAL cs + + +ralColorNames :: + HList + '[ RAL "Green beige" + , RAL "Beige" + , RAL "Sand yellow" + , RAL "Signal yellow" + , RAL "Golden yellow" + , RAL "Honey yellow" + , RAL "Maize yellow" + , RAL "Daffodil yellow" + , RAL "Brown beige" + , RAL "Lemon yellow" + , RAL "Oyster white" + , RAL "Ivory" + , RAL "Light ivory" + , RAL "Sulfur yellow" + , RAL "Saffron yellow" + , RAL "Zinc yellow" + , RAL "Grey beige" + , RAL "Olive yellow" + , RAL "Rape yellow" + , RAL "Traffic yellow" + , RAL "Ochre yellow" + , RAL "Luminous yellow" + , RAL "Curry yellow" + , RAL "Melon yellow" + , RAL "Broom yellow" + , RAL "Dahlia yellow" + , RAL "Pastel yellow" + , RAL "Pearl beige" + , RAL "Pearl gold" + , RAL "Sun yellow" + , RAL "Yellow orange" + , RAL "Red orange" + , RAL "Vermilion" + , RAL "Pastel orange" + , RAL "Pure orange" + , RAL "Luminous orange" + , RAL "Luminous bright orange" + , RAL "Bright red orange" + , RAL "Traffic orange" + , RAL "Signal orange" + , RAL "Deep orange" + , RAL "Salmon orange" + , RAL "Pearl orange" + , RAL "Flame red" + , RAL "Signal red" + , RAL "Carmine red" + , RAL "Ruby red" + , RAL "Purple red" + , RAL "Wine red" + , RAL "Black red" + , RAL "Oxide red" + , RAL "Brown red" + , RAL "Beige red" + , RAL "Tomato red" + , RAL "Antique pink" + , RAL "Light pink" + , RAL "Coral red" + , RAL "Rose" + , RAL "Strawberry red" + , RAL "Traffic red" + , RAL "Salmon pink" + , RAL "Luminous red" + , RAL "Luminous bright red" + , RAL "Raspberry red" + , RAL "Pure red" + , RAL "Orient red" + , RAL "Pearl ruby red" + , RAL "Pearl pink" + , RAL "Red lilac" + , RAL "Red violet" + , RAL "Heather violet" + , RAL "Claret violet" + , RAL "Blue lilac" + , RAL "Traffic purple" + , RAL "Purple violet" + , RAL "Signal violet" + , RAL "Pastel violet" + , RAL "Telemagenta" + , RAL "Pearl violet" + , RAL "Pearl blackberry" + , RAL "Violet blue" + , RAL "Green blue" + , RAL "Ultramarine blue" + , RAL "Sapphire blue" + , RAL "Black blue" + , RAL "Signal blue" + , RAL "Brilliant blue" + , RAL "Grey blue" + , RAL "Azure blue" + , RAL "Gentian blue" + , RAL "Steel blue" + , RAL "Light blue" + , RAL "Cobalt blue" + , RAL "Pigeon blue" + , RAL "Sky blue" + , RAL "Traffic blue" + , RAL "Turquoise blue" + , RAL "Capri blue" + , RAL "Ocean blue" + , RAL "Water blue" + , RAL "Night blue" + , RAL "Distant blue" + , RAL "Pastel blue" + , RAL "Pearl gentian blue" + , RAL "Pearl night blue" + , RAL "Patina green" + , RAL "Emerald green" + , RAL "Leaf green" + , RAL "Olive green" + , RAL "Blue green" + , RAL "Moss green" + , RAL "Grey olive" + , RAL "Bottle green" + , RAL "Brown green" + , RAL "Fir green" + , RAL "Grass green" + , RAL "Reseda green" + , RAL "Black green" + , RAL "Reed green" + , RAL "Yellow olive" + , RAL "Black olive" + , RAL "Turquoise green" + , RAL "May green" + , RAL "Yellow green" + , RAL "Pastel green" + , RAL "Chrome green" + , RAL "Pale green" + , RAL "Brown olive" + , RAL "Traffic green" + , RAL "Fern green" + , RAL "Opal green" + , RAL "Light green" + , RAL "Pine green" + , RAL "Mint green" + , RAL "Signal green" + , RAL "Mint turquoise" + , RAL "Pastel turquoise" + , RAL "Pearl green" + , RAL "Pearl opal green" + , RAL "Pure green" + , RAL "Luminous green" + , RAL "Squirrel grey" + , RAL "Silver grey" + , RAL "Olive grey" + , RAL "Moss grey" + , RAL "Signal grey" + , RAL "Mouse grey" + , RAL "Beige grey" + , RAL "Khaki grey" + , RAL "Green grey" + , RAL "Tarpaulin grey" + , RAL "Iron grey" + , RAL "Basalt grey" + , RAL "Brown grey" + , RAL "NATO olive" + , RAL "Slate grey" + , RAL "Anthracite grey" + , RAL "Black grey" + , RAL "Umbra grey" + , RAL "Concrete grey" + , RAL "Graphite grey" + , RAL "Granite grey" + , RAL "Stone grey" + , RAL "Blue grey" + , RAL "Pebble grey" + , RAL "Cement grey" + , RAL "Yellow grey" + , RAL "Light grey" + , RAL "Platinum grey" + , RAL "Dusty grey" + , RAL "Agate grey" + , RAL "Quartz grey" + , RAL "Window grey" + , RAL "Traffic grey A" + , RAL "Traffic grey B" + , RAL "Silk grey" + , RAL "Telegrey 1" + , RAL "Telegrey 2" + , RAL "Telegrey 4" + , RAL "Pearl mouse grey" + , RAL "Green brown" + , RAL "Ochre brown" + , RAL "Signal brown" + , RAL "Clay brown" + , RAL "Copper brown" + , RAL "Fawn brown" + , RAL "Olive brown" + , RAL "Nut brown" + , RAL "Red brown" + , RAL "Sepia brown" + , RAL "Chestnut brown" + , RAL "Mahogany brown" + , RAL "Chocolate brown" + , RAL "Grey brown" + , RAL "Black brown" + , RAL "Orange brown" + , RAL "Beige brown" + , RAL "Pale brown" + , RAL "Terra brown" + , RAL "Pearl copper" + , RAL "Cream" + , RAL "Grey white" + , RAL "Signal white" + , RAL "Signal black" + , RAL "Jet black" + , RAL "White aluminium" + , RAL "Grey aluminium" + , RAL "Pure white" + , RAL "Graphite black" + , RAL "Traffic white" + , RAL "Traffic black" + , RAL "Papyrus white" + , RAL "Pearl light grey" + , RAL "Pearl dark grey" + ] +ralColorNames = + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + HNil + + +ralColorCodes :: + HList + '[ RAL 1000 + , RAL 1001 + , RAL 1002 + , RAL 1003 + , RAL 1004 + , RAL 1005 + , RAL 1006 + , RAL 1007 + , RAL 1011 + , RAL 1012 + , RAL 1013 + , RAL 1014 + , RAL 1015 + , RAL 1016 + , RAL 1017 + , RAL 1018 + , RAL 1019 + , RAL 1020 + , RAL 1021 + , RAL 1023 + , RAL 1024 + , RAL 1026 + , RAL 1027 + , RAL 1028 + , RAL 1032 + , RAL 1033 + , RAL 1034 + , RAL 1035 + , RAL 1036 + , RAL 1037 + , RAL 2000 + , RAL 2001 + , RAL 2002 + , RAL 2003 + , RAL 2004 + , RAL 2005 + , RAL 2007 + , RAL 2008 + , RAL 2009 + , RAL 2010 + , RAL 2011 + , RAL 2012 + , RAL 2013 + , RAL 3000 + , RAL 3001 + , RAL 3002 + , RAL 3003 + , RAL 3004 + , RAL 3005 + , RAL 3007 + , RAL 3009 + , RAL 3011 + , RAL 3012 + , RAL 3013 + , RAL 3014 + , RAL 3015 + , RAL 3016 + , RAL 3017 + , RAL 3018 + , RAL 3020 + , RAL 3022 + , RAL 3024 + , RAL 3026 + , RAL 3027 + , RAL 3028 + , RAL 3031 + , RAL 3032 + , RAL 3033 + , RAL 4001 + , RAL 4002 + , RAL 4003 + , RAL 4004 + , RAL 4005 + , RAL 4006 + , RAL 4007 + , RAL 4008 + , RAL 4009 + , RAL 4010 + , RAL 4011 + , RAL 4012 + , RAL 5000 + , RAL 5001 + , RAL 5002 + , RAL 5003 + , RAL 5004 + , RAL 5005 + , RAL 5007 + , RAL 5008 + , RAL 5009 + , RAL 5010 + , RAL 5011 + , RAL 5012 + , RAL 5013 + , RAL 5014 + , RAL 5015 + , RAL 5017 + , RAL 5018 + , RAL 5019 + , RAL 5020 + , RAL 5021 + , RAL 5022 + , RAL 5023 + , RAL 5024 + , RAL 5025 + , RAL 5026 + , RAL 6000 + , RAL 6001 + , RAL 6002 + , RAL 6003 + , RAL 6004 + , RAL 6005 + , RAL 6006 + , RAL 6007 + , RAL 6008 + , RAL 6009 + , RAL 6010 + , RAL 6011 + , RAL 6012 + , RAL 6013 + , RAL 6014 + , RAL 6015 + , RAL 6016 + , RAL 6017 + , RAL 6018 + , RAL 6019 + , RAL 6020 + , RAL 6021 + , RAL 6022 + , RAL 6024 + , RAL 6025 + , RAL 6026 + , RAL 6027 + , RAL 6028 + , RAL 6029 + , RAL 6032 + , RAL 6033 + , RAL 6034 + , RAL 6035 + , RAL 6036 + , RAL 6037 + , RAL 6038 + , RAL 7000 + , RAL 7001 + , RAL 7002 + , RAL 7003 + , RAL 7004 + , RAL 7005 + , RAL 7006 + , RAL 7008 + , RAL 7009 + , RAL 7010 + , RAL 7011 + , RAL 7012 + , RAL 7013 + , RAL 7013 + , RAL 7015 + , RAL 7016 + , RAL 7021 + , RAL 7022 + , RAL 7023 + , RAL 7024 + , RAL 7026 + , RAL 7030 + , RAL 7031 + , RAL 7032 + , RAL 7033 + , RAL 7034 + , RAL 7035 + , RAL 7036 + , RAL 7037 + , RAL 7038 + , RAL 7039 + , RAL 7040 + , RAL 7042 + , RAL 7043 + , RAL 7044 + , RAL 7045 + , RAL 7046 + , RAL 7047 + , RAL 7048 + , RAL 8000 + , RAL 8001 + , RAL 8002 + , RAL 8003 + , RAL 8004 + , RAL 8007 + , RAL 8008 + , RAL 8011 + , RAL 8012 + , RAL 8014 + , RAL 8015 + , RAL 8016 + , RAL 8017 + , RAL 8019 + , RAL 8022 + , RAL 8023 + , RAL 8024 + , RAL 8025 + , RAL 8028 + , RAL 8029 + , RAL 9001 + , RAL 9002 + , RAL 9003 + , RAL 9004 + , RAL 9005 + , RAL 9006 + , RAL 9007 + , RAL 9010 + , RAL 9011 + , RAL 9016 + , RAL 9017 + , RAL 9018 + , RAL 9022 + , RAL 9023 + ] +ralColorCodes = + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + RAL :> + HNil + +-- Duplicates are marked by the boolean true. +ralColors :: ColorSpace cs i e => [(String, Color cs e, Bool)] +ralColors = + [ ("greenBeige", greenBeige, False) + , ("beige", beige, False) + , ("sandYellow", sandYellow, False) + , ("signalYellow", signalYellow, False) + , ("goldenYellow", goldenYellow, False) + , ("honeyYellow", honeyYellow, False) + , ("maizeYellow", maizeYellow, False) + , ("daffodilYellow", daffodilYellow, False) + , ("brownBeige", brownBeige, False) + , ("lemonYellow", lemonYellow, False) + , ("oysterWhite", oysterWhite, False) + , ("ivory", ivory, False) + , ("lightIvory", lightIvory, False) + , ("sulfurYellow", sulfurYellow, False) + , ("saffronYellow", saffronYellow, False) + , ("zincYellow", zincYellow, False) + , ("greyBeige", greyBeige, False) + , ("oliveYellow", oliveYellow, False) + , ("rapeYellow", rapeYellow, False) + , ("trafficYellow", trafficYellow, False) + , ("ochreYellow", ochreYellow, False) + , ("luminousYellow", luminousYellow, False) + , ("curryYellow", curryYellow, False) + , ("melonYellow", melonYellow, False) + , ("broomYellow", broomYellow, False) + , ("dahliaYellow", dahliaYellow, False) + , ("pastelYellow", pastelYellow, False) + , ("pearlBeige", pearlBeige, False) + , ("pearlGold", pearlGold, False) + , ("sunYellow", sunYellow, False) + , ("yellowOrange", yellowOrange, False) + , ("redOrange", redOrange, False) + , ("vermilion", vermilion, False) + , ("pastelOrange", pastelOrange, False) + , ("pureOrange", pureOrange, False) + , ("luminousOrange", luminousOrange, False) + , ("luminousBrightOrange", luminousBrightOrange, False) + , ("brightRedOrange", brightRedOrange, False) + , ("trafficOrange", trafficOrange, False) + , ("signalOrange", signalOrange, False) + , ("deepOrange", deepOrange, False) + , ("salmonOrange", salmonOrange, False) + , ("pearlOrange", pearlOrange, False) + , ("flameRed", flameRed, False) + , ("signalRed", signalRed, False) + , ("carmineRed", carmineRed, False) + , ("rubyRed", rubyRed, False) + , ("purpleRed", purpleRed, False) + , ("wineRed", wineRed, False) + , ("blackRed", blackRed, False) + , ("oxideRed", oxideRed, False) + , ("brownRed", brownRed, False) + , ("beigeRed", beigeRed, False) + , ("tomatoRed", tomatoRed, False) + , ("antiquePink", antiquePink, False) + , ("lightPink", lightPink, False) + , ("coralRed", coralRed, False) + , ("rose", rose, False) + , ("strawberryRed", strawberryRed, False) + , ("trafficRed", trafficRed, False) + , ("salmonPink", salmonPink, False) + , ("luminousRed", luminousRed, False) + , ("luminousBrightRed", luminousBrightRed, False) + , ("raspberryRed", raspberryRed, False) + , ("pureRed", pureRed, False) + , ("orientRed", orientRed, False) + , ("pearlRubyRed", pearlRubyRed, False) + , ("pearlPink", pearlPink, False) + , ("redLilac", redLilac, False) + , ("redViolet", redViolet, False) + , ("heatherViolet", heatherViolet, False) + , ("claretViolet", claretViolet, False) + , ("blueLilac", blueLilac, False) + , ("trafficPurple", trafficPurple, False) + , ("purpleViolet", purpleViolet, False) + , ("signalViolet", signalViolet, False) + , ("pastelViolet", pastelViolet, False) + , ("telemagenta", telemagenta, False) + , ("pearlViolet", pearlViolet, False) + , ("pearlBlackberry", pearlBlackberry, False) + , ("violetBlue", violetBlue, False) + , ("greenBlue", greenBlue, False) + , ("ultramarineBlue", ultramarineBlue, False) + , ("sapphireBlue", sapphireBlue, False) + , ("blackBlue", blackBlue, False) + , ("signalBlue", signalBlue, False) + , ("brilliantBlue", brilliantBlue, False) + , ("greyBlue", greyBlue, False) + , ("azureBlue", azureBlue, False) + , ("gentianBlue", gentianBlue, False) + , ("steelBlue", steelBlue, False) + , ("lightBlue", lightBlue, False) + , ("cobaltBlue", cobaltBlue, False) + , ("pigeonBlue", pigeonBlue, False) + , ("skyBlue", skyBlue, False) + , ("trafficBlue", trafficBlue, False) + , ("turquoiseBlue", turquoiseBlue, False) + , ("capriBlue", capriBlue, False) + , ("oceanBlue", oceanBlue, False) + , ("waterBlue", waterBlue, False) + , ("nightBlue", nightBlue, False) + , ("distantBlue", distantBlue, False) + , ("pastelBlue", pastelBlue, False) + , ("pearlGentianBlue", pearlGentianBlue, False) + , ("pearlNightBlue", pearlNightBlue, False) + , ("patinaGreen", patinaGreen, False) + , ("emeraldGreen", emeraldGreen, False) + , ("leafGreen", leafGreen, False) + , ("oliveGreen", oliveGreen, False) + , ("blueGreen", blueGreen, False) + , ("mossGreen", mossGreen, False) + , ("greyOlive", greyOlive, False) + , ("bottleGreen", bottleGreen, False) + , ("brownGreen", brownGreen, False) + , ("firGreen", firGreen, False) + , ("grassGreen", grassGreen, False) + , ("resedaGreen", resedaGreen, False) + , ("blackGreen", blackGreen, False) + , ("reedGreen", reedGreen, False) + , ("yellowOlive", yellowOlive, False) + , ("blackOlive", blackOlive, False) + , ("turquoiseGreen", turquoiseGreen, False) + , ("mayGreen", mayGreen, False) + , ("yellowGreen", yellowGreen, False) + , ("pastelGreen", pastelGreen, False) + , ("chromeGreen", chromeGreen, False) + , ("paleGreen", paleGreen, False) + , ("oliveDrab", oliveDrab, False) + , ("trafficGreen", trafficGreen, False) + , ("fernGreen", fernGreen, False) + , ("opalGreen", opalGreen, False) + , ("lightGreen", lightGreen, False) + , ("pineGreen", pineGreen, False) + , ("mintGreen", mintGreen, False) + , ("signalGreen", signalGreen, False) + , ("mintTurquoise", mintTurquoise, False) + , ("pastelTurquoise", pastelTurquoise, False) + , ("pearlGreen", pearlGreen, False) + , ("pearlOpalGreen", pearlOpalGreen, False) + , ("pureGreen", pureGreen, False) + , ("luminousGreen", luminousGreen, False) + , ("squirrelGrey", squirrelGrey, False) + , ("silverGrey", silverGrey, False) + , ("oliveGrey", oliveGrey, False) + , ("mossGrey", mossGrey, False) + , ("signalGrey", signalGrey, False) + , ("mouseGrey", mouseGrey, False) + , ("beigeGrey", beigeGrey, False) + , ("khakiGrey", khakiGrey, False) + , ("greenGrey", greenGrey, False) + , ("tarpaulinGrey", tarpaulinGrey, False) + , ("ironGrey", ironGrey, False) + , ("basaltGrey", basaltGrey, False) + , ("brownGrey", brownGrey, False) + , ("brownGrey", brownGrey, True) -- Alt: NATO olive + , ("slateGrey", slateGrey, False) + , ("anthraciteGrey", anthraciteGrey, False) + , ("blackGrey", blackGrey, False) + , ("umbraGrey", umbraGrey, False) + , ("concreteGrey", concreteGrey, False) + , ("graphiteGrey", graphiteGrey, False) + , ("graniteGrey", graniteGrey, False) + , ("stoneGrey", stoneGrey, False) + , ("blueGrey", blueGrey, False) + , ("pebbleGrey", pebbleGrey, False) + , ("cementGrey", cementGrey, False) + , ("yellowGrey", yellowGrey, False) + , ("lightGrey", lightGrey, False) + , ("platinumGrey", platinumGrey, False) + , ("dustyGrey", dustyGrey, False) + , ("agateGrey", agateGrey, False) + , ("quartzGrey", quartzGrey, False) + , ("windowGrey", windowGrey, False) + , ("trafficGreyA", trafficGreyA, False) + , ("trafficGreyB", trafficGreyB, False) + , ("silkGrey", silkGrey, False) + , ("telegrey1", telegrey1, False) + , ("telegrey2", telegrey2, False) + , ("telegrey4", telegrey4, False) + , ("pearlMouseGrey", pearlMouseGrey, False) + , ("greenBrown", greenBrown, False) + , ("ochreBrown", ochreBrown, False) + , ("signalBrown", signalBrown, False) + , ("clayBrown", clayBrown, False) + , ("copperBrown", copperBrown, False) + , ("fawnBrown", fawnBrown, False) + , ("oliveBrown", oliveBrown, False) + , ("nutBrown", nutBrown, False) + , ("redBrown", redBrown, False) + , ("sepiaBrown", sepiaBrown, False) + , ("chestnutBrown", chestnutBrown, False) + , ("mahoganyBrown", mahoganyBrown, False) + , ("chocolateBrown", chocolateBrown, False) + , ("greyBrown", greyBrown, False) + , ("blackBrown", blackBrown, False) + , ("orangeBrown", orangeBrown, False) + , ("beigeBrown", beigeBrown, False) + , ("paleBrown", paleBrown, False) + , ("terraBrown", terraBrown, False) + , ("pearlCopper", pearlCopper, False) + , ("cream", cream, False) + , ("greyWhite", greyWhite, False) + , ("signalWhite", signalWhite, False) + , ("signalBlack", signalBlack, False) + , ("jetBlack", jetBlack, False) + , ("whiteAluminium", whiteAluminium, False) + , ("greyAluminium", greyAluminium, False) + , ("pureWhite", pureWhite, False) + , ("graphiteBlack", graphiteBlack, False) + , ("trafficWhite", trafficWhite, False) + , ("trafficBlack", trafficBlack, False) + , ("papyrusWhite", papyrusWhite, False) + , ("pearlLightGrey", pearlLightGrey, False) + , ("pearlDarkGrey", pearlDarkGrey, False) + ] + + +ralAlternatives :: [(Color SRGB Word8, Color (HSL SRGB) Float, Color (CMYK SRGB) 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 + ] + where + ralAlternativeRaw :: + [(Float, Word8, Word8, Word8, Float, Float, Float, Word8, Word8, Word8, Word8)] + ralAlternativeRaw = + [ (186.29, 201, 187, 136, 47.08, 37.57, 66.08, 0, 7, 32, 21) + , (178.7, 204, 176, 131, 36.99, 41.71, 65.69, 0, 14, 36, 20) + , (173.04, 205, 170, 109, 38.13, 48.98, 61.57, 0, 17, 47, 20) + , (172.32, 242, 169, 0, 41.90, 100, 47.45, 0, 30, 100, 5) + , (160.7, 221, 159, 0, 43.17, 100, 43.33, 0, 28, 100, 13) + , (144.16, 197, 143, 0, 43.55, 100, 38.63, 0, 27, 100, 23) + , (150.26, 219, 145, 0, 39.73, 100, 42.94, 0, 34, 100, 14) + , (148.89, 226, 141, 0, 37.43, 100, 44.31, 0, 38, 100, 11) + , (134.32, 171, 129, 79, 32.61, 36.8, 49.02, 0, 25, 54, 33) + , (174.04, 214, 176, 37, 47.12, 70.52, 49.22, 0, 18, 83, 16) + , (218.12, 225, 218, 199, 43.85, 30.23, 83.14, 0, 3, 12, 12) + , (198.15, 217, 197, 154, 40.95, 45.32, 72.75, 0, 9, 29, 15) + , (212.24, 227, 211, 181, 39.13, 45.1, 80, 0, 7, 20, 11) + , (211.92, 232, 222, 53, 56.65, 79.56, 55.88, 0, 4, 77, 9) + , (178.38, 240, 170, 80, 33.75, 84.21, 62.75, 0, 29, 67, 6) + , (199.96, 242, 203, 46, 48.06, 88.29, 56.47, 0, 16, 81, 5) + , (145.52, 162, 143, 122, 31.50, 17.7, 55.69, 0, 12, 25, 36) + , (142.94, 157, 143, 101, 45, 22.22, 50.59, 0, 9, 36, 38) + , (181.48, 238, 183, 0, 46.13, 100, 46.67, 0, 23, 100, 7) + , (181.69, 239, 183, 0, 45.94, 100, 46.86, 0, 23, 100, 6) + , (146.88, 181, 144, 75, 39.06, 41.73, 50.2, 0, 20, 59, 29) + , (236.59, 255, 255, 0, 0.17, 100, 50, 0, 0, 100, 0) + , (126.85, 162, 128, 12, 46.40, 86.21, 34.12, 0, 21, 93, 36) + , (165.78, 255, 156, 0, 0.10, 100, 50, 0, 39, 100, 0) + , (163.85, 219, 164, 0, 44.93, 100, 42.94, 0, 25, 100, 14) + , (164.47, 243, 155, 27, 35.56, 90, 52.94, 0, 36, 89, 5) + , (167.03, 230, 157, 81, 30.60, 74.87, 60.98, 0, 32, 65, 10) + , (131.97, 142, 131, 112, 38, 11.81, 49.8, 0, 8, 21, 44) + , (103.36, 125, 101, 63, 36.77, 32.98, 36.86, 0, 19, 50, 51) + , (154.88, 234, 147, 0, 37.69, 100, 45.88, 0, 37, 100, 8) + , (124.67, 213, 111, 0, 31.27, 100, 41.76, 0, 48, 100, 16) + , (92.21, 182, 72, 28, 17.14, 73.33, 41.18, 0, 60, 85, 29) + , (82.55, 188, 56, 35, 8.24, 68.61, 43.73, 0, 70, 81, 26) + , (140.02, 241, 120, 41, 23.70, 87.72, 55.29, 0, 50, 83, 5) + , (106.99, 222, 83, 6, 21.39, 94.74, 44.71, 0, 63, 97, 13) + , (109.08, 255, 75, 17, 14.62, 100, 53.33, 0, 71, 93, 0) + , (185.09, 255, 183, 0, 0.12, 100, 50, 0, 28, 100, 0) + , (128.3, 232, 107, 34, 22.12, 81.15, 52.16, 0, 54, 85, 9) + , (106.43, 218, 83, 10, 21.06, 91.23, 44.71, 0, 62, 95, 15) + , (112.84, 204, 93, 41, 19.14, 66.53, 48.04, 0, 54, 80, 20) + , (126.74, 221, 110, 15, 27.67, 87.29, 46.27, 0, 50, 93, 13) + , (122.3, 209, 101, 78, 10.53, 58.74, 56.27, 0, 52, 63, 18) + , (77.49, 143, 62, 38, 13.71, 58.01, 35.49, 0, 57, 73, 44) + , (65.86, 164, 40, 33, 3.21, 66.5, 38.63, 0, 76, 80, 36) + , (59.87, 152, 35, 35, 0, 62.57, 36.67, 0, 77, 77, 40) + , (59.09, 152, 34, 34, 0, 63.44, 36.47, 0, 78, 78, 40) + , (48.4, 132, 25, 34, 354.95, 68.15, 30.78, 0, 81, 74, 48) + , (44.16, 105, 27, 35, 353.85, 59.09, 25.88, 0, 74, 67, 59) + , (38.11, 88, 24, 31, 353.44, 57.14, 21.96, 0, 73, 65, 65) + , (38.31, 61, 32, 34, 355.86, 31.18, 18.24, 0, 48, 44, 76) + , (58.98, 102, 48, 41, 6.89, 42.66, 28.04, 0, 53, 60, 60) + , (53.65, 119, 36, 36, 0, 53.55, 30.39, 0, 70, 70, 53) + , (144.24, 194, 133, 109, 16.94, 41.06, 59.41, 0, 31, 44, 24) + , (67.25, 149, 46, 37, 4.82, 60.22, 36.47, 0, 69, 75, 42) + , (133.43, 201, 115, 117, 358.60, 44.33, 61.96, 0, 43, 42, 21) + , (172.13, 215, 160, 166, 353.45, 40.74, 73.53, 0, 26, 23, 16) + , (81.24, 164, 60, 48, 6.21, 54.72, 41.57, 0, 63, 71, 36) + , (109.31, 200, 84, 93, 355.34, 51.33, 55.69, 0, 58, 53, 22) + , (91.35, 196, 62, 74, 354.63, 53.17, 50.59, 0, 68, 62, 23) + , (61.23, 184, 29, 19, 3.64, 81.28, 39.8, 0, 84, 90, 28) + , (124.6, 204, 105, 85, 10.08, 53.85, 56.67, 0, 49, 58, 20) + , (86.85, 255, 42, 36, 1.64, 100, 57.06, 0, 84, 86, 0) + , (83.7, 255, 38, 32, 1.61, 100, 56.27, 0, 85, 87, 0) + , (67.51, 169, 38, 61, 349.47, 63.29, 40.59, 0, 78, 64, 34) + , (76.23, 201, 43, 38, 1.84, 68.2, 46.86, 0, 79, 81, 21) + , (75.38, 164, 51, 56, 357.35, 52.56, 42.16, 0, 69, 66, 36) + , (46.01, 110, 28, 36, 354.15, 59.42, 27.06, 0, 75, 67, 57) + , (78.53, 162, 57, 46, 5.69, 55.77, 40.78, 0, 65, 72, 36) + , (105.97, 131, 96, 131, 0.83, 15.42, 44.51, 0, 27, 0, 49) + , (78.09, 140, 60, 75, 348.75, 40, 39.22, 0, 57, 46, 45) + , (120.44, 196, 96, 140, 333.60, 45.87, 57.25, 0, 51, 29, 23) + , (46.12, 100, 29, 57, 336.34, 55.04, 25.29, 0, 71, 43, 61) + , (110.93, 123, 103, 154, 263.53, 20.16, 50.39, 20, 33, 0, 40) + , (73.46, 145, 48, 115, 318.56, 50.26, 37.84, 0, 67, 21, 43) + , (45.17, 71, 36, 60, 318.86, 32.71, 20.98, 0, 49, 15, 72) + , (91.8, 135, 75, 131, 304, 28.57, 41.18, 0, 44, 3, 47) + , (139.04, 157, 133, 146, 327.50, 10.91, 56.86, 0, 15, 7, 38) + , (92.69, 187, 62, 119, 332.64, 50.2, 48.82, 0, 67, 36, 27) + , (103.86, 113, 98, 135, 264.32, 15.88, 45.69, 16, 27, 0, 47) + , (108.87, 109, 107, 127, 246, 8.55, 45.88, 14, 16, 0, 50) + , (75.71, 56, 78, 111, 216, 32.93, 32.75, 50, 30, 0, 56) + , (67.74, 29, 76, 100, 200.28, 55.04, 25.29, 71, 24, 0, 61) + , (53.88, 30, 54, 123, 224.52, 60.78, 30, 76, 56, 0, 52) + , (54.27, 38, 56, 85, 217.02, 38.21, 24.12, 55, 34, 0, 67) + , (29.87, 26, 30, 40, 222.86, 21.21, 12.94, 35, 25, 0, 84) + , (67.68, 0, 81, 135, 204, 100, 26.47, 100, 40, 0, 47) + , (99.95, 66, 106, 140, 207.57, 35.92, 40.39, 53, 24, 0, 45) + , (55.96, 45, 58, 68, 206.09, 20.35, 22.16, 34, 15, 0, 73) + , (85.46, 45, 94, 120, 200.80, 45.45, 32.35, 62, 22, 0, 53) + , (64.74, 0, 78, 124, 202.26, 100, 24.31, 100, 37, 0, 51) + , (41.54, 30, 43, 61, 214.84, 34.07, 17.84, 51, 30, 0, 76) + , (120.19, 46, 136, 182, 200.29, 59.65, 44.71, 75, 25, 0, 29) + , (47.55, 34, 48, 83, 222.86, 41.88, 22.94, 59, 42, 0, 67) + , (121.63, 104, 124, 150, 213.91, 18.11, 49.8, 31, 17, 0, 41) + , (103.02, 11, 123, 176, 199.27, 88.24, 36.67, 94, 30, 0, 31) + , (74.48, 0, 90, 140, 201.43, 100, 27.45, 100, 36, 0, 45) + , (115.26, 27, 139, 140, 180.53, 67.66, 32.75, 81, 1, 0, 45) + , (79.23, 15, 93, 132, 200, 79.59, 28.82, 89, 30, 0, 48) + , (51.9, 0, 65, 75, 188, 100, 14.71, 100, 13, 0, 71) + , (92.27, 0, 117, 119, 181.01, 100, 23.33, 100, 2, 0, 53) + , (47.11, 43, 44, 90, 238.72, 35.34, 26.08, 52, 51, 0, 65) + , (100.29, 74, 104, 141, 213.13, 31.16, 42.16, 48, 26, 0, 45) + , (138.74, 103, 146, 172, 202.61, 29.36, 53.92, 40, 15, 0, 33) + , (93.4, 44, 105, 124, 194.25, 47.62, 32.94, 65, 15, 0, 51) + , (45.28, 27, 47, 82, 218.18, 50.46, 21.37, 67, 43, 0, 68) + , (102.44, 59, 116, 96, 158.95, 32.57, 34.31, 49, 0, 17, 55) + , (88.55, 49, 104, 52, 123.27, 35.95, 30, 53, 0, 50, 59) + , (76.75, 45, 90, 39, 112.94, 39.53, 25.29, 50, 0, 57, 65) + , (80.2, 78, 83, 59, 72.50, 16.9, 27.84, 6, 0, 29, 67) + , (55.1, 8, 68, 66, 178, 78.95, 14.9, 88, 0, 3, 73) + , (54.43, 17, 66, 50, 160.41, 59.04, 16.27, 74, 0, 24, 74) + , (56.63, 59, 57, 46, 50.77, 12.38, 20.59, 0, 3, 22, 77) + , (47.14, 42, 50, 34, 90, 19.05, 16.47, 16, 0, 32, 80) + , (51.7, 54, 52, 42, 50, 12.5, 18.82, 0, 4, 22, 79) + , (49.94, 39, 54, 42, 132, 16.13, 18.24, 28, 0, 22, 79) + , (98.74, 72, 111, 56, 102.55, 32.93, 32.75, 35, 0, 50, 56) + , (118.08, 105, 125, 88, 92.43, 17.37, 41.76, 16, 0, 30, 51) + , (58.02, 48, 61, 58, 166.15, 11.93, 21.37, 21, 0, 5, 76) + , (116.83, 122, 118, 90, 52.50, 15.09, 41.57, 0, 3, 26, 52) + , (65.2, 70, 65, 53, 42.35, 13.82, 24.12, 0, 7, 24, 73) + , (60.28, 60, 61, 54, 68.57, 6.09, 22.55, 2, 0, 11, 76) + , (81.3, 0, 106, 76, 163.02, 100, 20.78, 100, 0, 28, 58) + , (113.74, 83, 128, 63, 101.54, 34.03, 37.45, 35, 0, 51, 50) + , (133.18, 89, 154, 57, 100.21, 45.97, 41.37, 42, 0, 63, 40) + , (198.66, 183, 206, 172, 100.59, 25.76, 74.12, 11, 0, 17, 19) + , (62.08, 54, 66, 47, 97.89, 16.81, 22.16, 18, 0, 29, 74) + , (147.43, 135, 154, 119, 92.57, 14.77, 53.53, 12, 0, 23, 40) + , (51.41, 57, 51, 39, 40, 18.75, 18.82, 0, 11, 32, 78) + , (100.18, 0, 132, 80, 156.36, 100, 25.88, 100, 0, 39, 48) + , (102.07, 90, 110, 59, 83.53, 30.18, 33.14, 18, 0, 46, 57) + , (73.58, 0, 95, 78, 169.26, 100, 18.63, 100, 0, 18, 63) + , (173.31, 128, 186, 181, 174.83, 29.59, 61.57, 31, 0, 3, 27) + , (75.05, 48, 84, 66, 150, 27.27, 25.88, 43, 0, 21, 67) + , (84.43, 0, 112, 60, 152.14, 100, 21.96, 100, 0, 46, 56) + , (103.35, 28, 128, 81, 151.80, 64.1, 30.59, 78, 0, 37, 50) + , (121.03, 72, 135, 127, 172.38, 30.43, 40.59, 47, 0, 6, 47) + , (162.51, 124, 173, 172, 178.78, 23, 58.24, 28, 0, 1, 32) + , (61.71, 19, 77, 36, 137.59, 60.42, 18.82, 75, 0, 53, 70) + , (69.84, 7, 88, 75, 170.37, 85.26, 18.63, 92, 0, 15, 65) + , (102.94, 0, 140, 39, 136.71, 100, 27.45, 100, 0, 72, 45) + , (131.47, 0, 182, 18, 125.93, 100, 35.69, 100, 0, 90, 29) + , (133.67, 123, 136, 142, 198.95, 7.76, 51.96, 13, 4, 0, 44) + , (148.8, 142, 150, 157, 208, 7.11, 58.63, 10, 4, 0, 38) + , (119.97, 127, 120, 99, 45, 12.39, 44.31, 0, 6, 22, 50) + , (118.2, 120, 119, 105, 56, 6.67, 44.12, 0, 1, 13, 53) + , (155, 155, 155, 155, 0.61, 0, 60.78, 0, 0, 0, 39) + , (109.15, 107, 110, 107, 120, 1.38, 42.55, 3, 0, 3, 57) + , (107.47, 117, 106, 94, 31.30, 10.9, 41.37, 0, 9, 20, 54) + , (96.51, 114, 95, 60, 38.89, 31.03, 34.12, 0, 17, 47, 55) + , (94.57, 92, 96, 88, 90, 4.35, 36.08, 4, 0, 8, 62) + , (90.72, 88, 92, 86, 100, 3.37, 34.9, 4, 0, 7, 64) + , (88.01, 83, 89, 93, 204, 5.68, 34.51, 11, 4, 0, 64) + , (92.01, 88, 93, 94, 190, 3.3, 35.69, 6, 1, 0, 63) + , (80.41, 86, 80, 68, 40, 11.69, 30.2, 0, 7, 21, 66) + , (82.8, 80, 83, 89, 220, 5.33, 33.14, 10, 7, 0, 65) + , (61.01, 56, 62, 66, 204, 8.2, 23.92, 15, 6, 0, 74) + , (49.72, 48, 50, 52, 210, 4, 19.61, 8, 4, 0, 80) + , (73.99, 76, 74, 68, 45, 5.56, 28.24, 0, 3, 11, 70) + , (127.07, 127, 128, 118, 66, 4.07, 48.24, 1, 0, 8, 50) + , (72.8, 70, 73, 79, 220, 6.04, 29.22, 11, 8, 0, 69) + , (64.81, 56, 67, 69, 189.23, 10.4, 24.51, 19, 3, 0, 73) + , (141.99, 145, 142, 133, 45, 5.17, 54.51, 0, 2, 8, 43) + , (102.02, 93, 104, 109, 198.75, 7.92, 39.61, 15, 5, 0, 57) + , (175.77, 180, 176, 161, 47.37, 11.24, 66.86, 0, 2, 11, 29) + , (128.14, 126, 130, 116, 77.14, 5.69, 48.24, 3, 0, 11, 49) + , (135.9, 144, 136, 111, 0.13, 12.94, 50, 0, 6, 23, 44) + , (198.36, 197, 199, 196, 100, 2.61, 77.45, 1, 0, 2, 22) + , (147.78, 151, 147, 146, 12, 2.35, 58.24, 0, 3, 3, 41) + , (122.72, 122, 123, 122, 120, 0.41, 48.04, 1, 0, 1, 52) + , (176, 175, 177, 169, 75, 4.88, 67.84, 1, 0, 5, 31) + , (102.27, 106, 102, 94, 40, 6, 39.22, 0, 4, 11, 58) + , (156.94, 152, 158, 161, 200, 4.57, 61.37, 6, 2, 0, 37) + , (145.08, 142, 146, 145, 165, 1.8, 56.47, 3, 0, 1, 43) + , (81.22, 79, 82, 80, 140, 1.86, 31.57, 4, 0, 2, 68) + , (178.84, 182, 179, 168, 47.14, 8.75, 68.63, 0, 2, 8, 29) + , (145.37, 142, 146, 149, 205.71, 3.2, 57.06, 5, 2, 0, 42) + , (132.8, 127, 134, 138, 201.82, 4.49, 51.96, 8, 3, 0, 46) + , (199.93, 200, 200, 199, 0.17, 0.9, 78.24, 0, 0, 0, 22) + , (123.49, 128, 123, 115, 36.92, 5.35, 47.65, 0, 4, 10, 50) + , (108.78, 134, 106, 62, 36.67, 36.73, 38.43, 0, 21, 54, 47) + , (106.44, 153, 99, 43, 30.55, 56.12, 38.43, 0, 35, 72, 40) + , (84.85, 119, 77, 62, 15.79, 31.49, 35.49, 0, 35, 48, 53) + , (82.82, 124, 75, 39, 25.41, 52.15, 31.96, 0, 40, 69, 51) + , (85.09, 138, 73, 49, 16.18, 47.59, 36.67, 0, 47, 64, 46) + , (76.34, 109, 70, 43, 24.55, 43.42, 29.8, 0, 36, 61, 57) + , (79.19, 111, 74, 37, 30, 50, 29.02, 0, 33, 67, 56) + , (61.58, 88, 56, 39, 20.82, 38.58, 24.9, 0, 36, 56, 65) + , (60.84, 100, 51, 43, 8.42, 39.86, 28.04, 0, 49, 57, 61) + , (55.96, 72, 53, 38, 26.47, 30.91, 21.57, 0, 26, 47, 72) + , (56.2, 93, 47, 39, 8.89, 40.91, 25.88, 0, 49, 58, 64) + , (49.01, 75, 43, 32, 15.35, 40.19, 20.98, 0, 43, 57, 71) + , (50.82, 67, 47, 41, 13.85, 24.07, 21.18, 0, 30, 39, 74) + , (55.42, 61, 54, 53, 7.50, 7.02, 22.35, 0, 11, 13, 76) + , (23.78, 26, 23, 25, 320, 6.12, 9.61, 0, 12, 4, 90) + , (99.2, 160, 87, 41, 23.19, 59.2, 39.41, 0, 46, 74, 37) + , (86.35, 118, 80, 56, 23.23, 35.63, 34.12, 0, 32, 53, 54) + , (92.51, 115, 88, 71, 23.18, 23.66, 36.47, 0, 23, 38, 55) + , (61.31, 79, 58, 42, 25.95, 30.58, 23.73, 0, 27, 47, 69) + , (75.89, 125, 64, 49, 11.84, 43.68, 34.12, 0, 49, 61, 51) + , (225.19, 231, 225, 210, 42.86, 30.43, 86.47, 0, 3, 9, 9) + , (212.49, 214, 213, 203, 54.55, 11.83, 81.76, 0, 0, 5, 16) + , (235.64, 236, 236, 231, 0.17, 11.63, 91.57, 0, 0, 2, 7) + , (43.07, 43, 43, 44, 240, 1.15, 17.06, 2, 2, 0, 83) + , (14.14, 14, 14, 16, 240, 6.67, 5.88, 12, 12, 0, 94) + , (160.93, 161, 161, 160, 0.17, 0.53, 62.94, 0, 0, 1, 37) + , (132.92, 134, 133, 129, 48, 2.02, 51.57, 0, 1, 4, 47) + , (236.77, 240, 237, 225, 48, 33.33, 91.18, 0, 1, 6, 6) + , (40.72, 39, 41, 43, 210, 4.88, 16.08, 9, 5, 0, 83) + , (240.28, 240, 241, 234, 68.57, 20, 93.14, 0, 0, 3, 5) + , (41.28, 42, 41, 42, 0.83, 1.2, 16.27, 0, 2, 0, 84) + , (201.64, 199, 203, 196, 94.29, 6.31, 78.24, 2, 0, 3, 20) + , (132.86, 133, 133, 131, 0.17, 0.81, 51.76, 0, 0, 2, 48) + , (122.57, 121, 123, 123, 0.50, 0.82, 47.84, 2, 0, 0, 52) + ] + +_hexes :: [Color SRGB Word8] +_hexes = + [ fromIntegral <$> + fromComponents (shiftR (x .&. 0xFF0000) 16, shiftR (x .&. 0xFF00) 8, x .&. 0xFF) + | x <- + [ 0xCDBA88 :: Word32 + , 0xD0B084 + , 0xD2AA6D + , 0xF9A800 + , 0xE49E00 + , 0xCB8E00 + , 0xE29000 + , 0xE88C00 + , 0xAF804F + , 0xDDAF27 + , 0xE3D9C6 + , 0xDDC49A + , 0xE6D2B5 + , 0xF1DD38 + , 0xF6A950 + , 0xFACA30 + , 0xA48F7A + , 0xA08F65 + , 0xF6B600 + , 0xF7B500 + , 0xBA8F4C + , 0xFFFF00 + , 0xA77F0E + , 0xFF9B00 + , 0xE2A300 + , 0xF99A1C + , 0xEB9C52 + , 0x908370 + , 0x80643F + , 0xF09200 + , 0xDD7907 + , 0xBE4E20 + , 0xC63927 + , 0xFA842B + , 0xE75B12 + , 0xFF2300 + , 0xFFA421 + , 0xF3752C + , 0xE15501 + , 0xD4652F + , 0xEC7C25 + , 0xDB6A50 + , 0x954527 + , 0xAB2524 + , 0xA02128 + , 0xA1232B + , 0x8D1D2C + , 0x701F29 + , 0x5E2028 + , 0x402225 + , 0x703731 + , 0x7E292C + , 0xCB8D73 + , 0x9C322E + , 0xD47479 + , 0xE1A6AD + , 0xAC4034 + , 0xD3545F + , 0xD14152 + , 0xC1121C + , 0xD56D56 + , 0xF70000 + , 0xFF0000 + , 0xB42041 + , 0xE72512 + , 0xAC323B + , 0x711521 + , 0xB24C43 + , 0x8A5A83 + , 0x933D50 + , 0xD15B8F + , 0x691639 + , 0x83639D + , 0x992572 + , 0x4A203B + , 0x904684 + , 0xA38995 + , 0xC63678 + , 0x8773A1 + , 0x6B6880 + , 0x384C70 + , 0x1F4764 + , 0x2B2C7C + , 0x2A3756 + , 0x1D1F2A + , 0x154889 + , 0x41678D + , 0x313C48 + , 0x2E5978 + , 0x13447C + , 0x232C3F + , 0x3481B8 + , 0x232D53 + , 0x6C7C98 + , 0x2874B2 + , 0x0E518D + , 0x21888F + , 0x1A5784 + , 0x0B4151 + , 0x07737A + , 0x2F2A5A + , 0x4D668E + , 0x6A93B0 + , 0x296478 + , 0x102C54 + , 0x327662 + , 0x28713E + , 0x276235 + , 0x4B573E + , 0x0E4243 + , 0x0F4336 + , 0x40433B + , 0x283424 + , 0x35382E + , 0x26392F + , 0x3E753B + , 0x68825B + , 0x31403D + , 0x797C5A + , 0x444337 + , 0x3D403A + , 0x026A52 + , 0x468641 + , 0x48A43F + , 0xB7D9B1 + , 0x354733 + , 0x86A47C + , 0x3E3C32 + , 0x008754 + , 0x53753C + , 0x005D52 + , 0x81C0BB + , 0x2D5546 + , 0x007243 + , 0x0F8558 + , 0x478A84 + , 0x7FB0B2 + , 0x1B542C + , 0x005D4C + , 0x25E712 + , 0x00F700 + , 0x7E8B92 + , 0x8F999F + , 0x817F68 + , 0x7A7B6D + , 0x9EA0A1 + , 0x6B716F + , 0x756F61 + , 0x746643 + , 0x5B6259 + , 0x575D57 + , 0x555D61 + , 0x596163 + , 0x555548 + , 0x51565C + , 0x373F43 + , 0x2E3234 + , 0x4B4D46 + , 0x818479 + , 0x474A50 + , 0x374447 + , 0x939388 + , 0x5D6970 + , 0xB9B9A8 + , 0x818979 + , 0x939176 + , 0xCBD0CC + , 0x9A9697 + , 0x7C7F7E + , 0xB4B8B0 + , 0x6B695F + , 0x9DA3A6 + , 0x8F9695 + , 0x4E5451 + , 0xBDBDB2 + , 0x91969A + , 0x82898E + , 0xCFD0CF + , 0x888175 + , 0x887142 + , 0x9C6B30 + , 0x7B5141 + , 0x80542F + , 0x8F4E35 + , 0x6F4A2F + , 0x6F4F28 + , 0x5A3A29 + , 0x673831 + , 0x49392D + , 0x633A34 + , 0x4C2F26 + , 0x44322D + , 0x3F3A3A + , 0x211F20 + , 0xA65E2F + , 0x79553C + , 0x755C49 + , 0x4E3B2B + , 0x773C27 + , 0xEFEBDC + , 0xDDDED4 + , 0xF4F8F4 + , 0x2E3032 + , 0x0A0A0D + , 0xA5A8A6 + , 0x8F8F8C + , 0xF7F9EF + , 0x292C2F + , 0xF7FBF5 + , 0x2A2D2F + , 0xCFD3CD + , 0x9C9C9C + , 0x7E8182 + ] + ] diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Spec +import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout) +import Test.Hspec + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hspec spec diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,12 @@ +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