Color (empty) → 0.1.0
raw patch · 68 files changed
+10617/−0 lines, 68 filesdep +HUnitdep +QuickCheckdep +basebuild-type:Customsetup-changed
Dependencies added: HUnit, QuickCheck, base, color, colour, criterion, data-default-class, deepseq, doctest, hspec, random, template-haskell, vector
Files
- CHANGELOG.md +5/−0
- Color.cabal +173/−0
- LICENSE +30/−0
- README.md +58/−0
- Setup.hs +34/−0
- bench/Conversion.hs +116/−0
- src/Graphics/Color/Adaptation.hs +20/−0
- src/Graphics/Color/Adaptation/Internal.hs +107/−0
- src/Graphics/Color/Adaptation/VonKries.hs +219/−0
- src/Graphics/Color/Algebra.hs +476/−0
- src/Graphics/Color/Algebra/Binary.hs +236/−0
- src/Graphics/Color/Algebra/Elevator.hs +425/−0
- src/Graphics/Color/Illuminant/CIE1931.hs +516/−0
- src/Graphics/Color/Illuminant/CIE1964.hs +211/−0
- src/Graphics/Color/Illuminant/ICC/PCS.hs +26/−0
- src/Graphics/Color/Illuminant/ITU/Rec470.hs +42/−0
- src/Graphics/Color/Illuminant/ITU/Rec601.hs +27/−0
- src/Graphics/Color/Model.hs +49/−0
- src/Graphics/Color/Model/Alpha.hs +137/−0
- src/Graphics/Color/Model/CMYK.hs +114/−0
- src/Graphics/Color/Model/HSI.hs +141/−0
- src/Graphics/Color/Model/HSL.hs +119/−0
- src/Graphics/Color/Model/HSV.hs +135/−0
- src/Graphics/Color/Model/Internal.hs +278/−0
- src/Graphics/Color/Model/RGB.hs +77/−0
- src/Graphics/Color/Model/Y.hs +109/−0
- src/Graphics/Color/Model/YCbCr.hs +100/−0
- src/Graphics/Color/Space.hs +16/−0
- src/Graphics/Color/Space/CIE1931/XYZ.hs +15/−0
- src/Graphics/Color/Space/CIE1976/LAB.hs +153/−0
- src/Graphics/Color/Space/Internal.hs +477/−0
- src/Graphics/Color/Space/RGB.hs +26/−0
- src/Graphics/Color/Space/RGB/AdobeRGB.hs +180/−0
- src/Graphics/Color/Space/RGB/Alternative.hs +19/−0
- src/Graphics/Color/Space/RGB/Alternative/CMYK.hs +92/−0
- src/Graphics/Color/Space/RGB/Alternative/HSI.hs +104/−0
- src/Graphics/Color/Space/RGB/Alternative/HSL.hs +103/−0
- src/Graphics/Color/Space/RGB/Alternative/HSV.hs +102/−0
- src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs +147/−0
- src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs +89/−0
- src/Graphics/Color/Space/RGB/Derived/SRGB.hs +96/−0
- src/Graphics/Color/Space/RGB/ITU/Rec470.hs +177/−0
- src/Graphics/Color/Space/RGB/ITU/Rec601.hs +215/−0
- src/Graphics/Color/Space/RGB/ITU/Rec709.hs +104/−0
- src/Graphics/Color/Space/RGB/Internal.hs +298/−0
- src/Graphics/Color/Space/RGB/Luma.hs +134/−0
- src/Graphics/Color/Space/RGB/SRGB.hs +188/−0
- src/Graphics/Color/Standard/RAL.hs +1139/−0
- src/Graphics/Pixel.hs +130/−0
- src/Graphics/Pixel/ColorSpace.hs +306/−0
- src/Graphics/Pixel/Internal.hs +175/−0
- tests/Graphics/Color/Model/CMYKSpec.hs +21/−0
- tests/Graphics/Color/Model/Common.hs +123/−0
- tests/Graphics/Color/Model/HSISpec.hs +48/−0
- tests/Graphics/Color/Model/HSLSpec.hs +49/−0
- tests/Graphics/Color/Model/HSVSpec.hs +48/−0
- tests/Graphics/Color/Model/RGBSpec.hs +39/−0
- tests/Graphics/Color/Space/CIE1931/IlluminantSpec.hs +50/−0
- tests/Graphics/Color/Space/CIE1976/LABSpec.hs +21/−0
- tests/Graphics/Color/Space/Common.hs +40/−0
- tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs +21/−0
- tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs +20/−0
- tests/Graphics/Color/Space/RGB/SRGBSpec.hs +16/−0
- tests/Graphics/Color/Space/YUV/YCbCrSpec.hs +17/−0
- tests/Graphics/Color/Standard/RALSpec.hs +1616/−0
- tests/Main.hs +10/−0
- tests/Spec.hs +1/−0
- tests/doctests.hs +12/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for color++## 0.0.0++Initial alpha release
+ Color.cabal view
@@ -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 <https://github.com/lehins/color#readme>+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
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,58 @@+# color++| Language | Travis | Coveralls |Gitter.im |+|:--------:|:------:|:---------:|:--------:|+|  | [](https://travis-ci.org/lehins/color) | [](https://coveralls.io/github/lehins/color?branch=master) | [](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)| [](https://hackage.haskell.org/package/color)| [](https://www.stackage.org/nightly/package/color)| [](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
+ Setup.hs view
@@ -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+
+ bench/Conversion.hs view
@@ -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)
+ src/Graphics/Color/Adaptation.hs view
@@ -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 <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Adaptation/Internal.hs view
@@ -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 <lehins@yandex.ru>+-- 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)
+ src/Graphics/Color/Adaptation/VonKries.hs view
@@ -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 <lehins@yandex.ru>+-- 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)+-- <RGB:(226,141, 0)>+++--+-- 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)+-- <RGB:(242,203, 46)>+++-- -- 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)+-- <RGB:(201,187,136)>++-- 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)
+ src/Graphics/Color/Algebra.hs view
@@ -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 <lehins@yandex.ru>+-- 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)
+ src/Graphics/Color/Algebra/Binary.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Algebra/Elevator.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Illuminant/CIE1931.hs view
@@ -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 <lehins@yandex.ru>+-- 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)+ ]
+ src/Graphics/Color/Illuminant/CIE1964.hs view
@@ -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 <lehins@yandex.ru>+-- 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)
+ src/Graphics/Color/Illuminant/ICC/PCS.hs view
@@ -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 <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Illuminant/ITU/Rec470.hs view
@@ -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 <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Illuminant/ITU/Rec601.hs view
@@ -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 <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Model.hs view
@@ -0,0 +1,49 @@+-- |+-- Module : Graphics.Color.Model+-- Copyright : (c) Alexey Kuleshevich 2018-2019+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Model/Alpha.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Model/CMYK.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Model/HSI.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Model/HSL.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Model/HSV.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Model/Internal.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Model/RGB.hs view
@@ -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 <lehins@yandex.ru>+-- 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)
+ src/Graphics/Color/Model/Y.hs view
@@ -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 <lehins@yandex.ru>+-- 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+ }
+ src/Graphics/Color/Model/YCbCr.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Space.hs view
@@ -0,0 +1,16 @@+-- |+-- Module : Graphics.Color.Space+-- Copyright : (c) Alexey Kuleshevich 2018-2019+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Space/CIE1931/XYZ.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE PatternSynonyms #-}+-- |+-- Module : Graphics.Color.Space.CIE1931.XYZ+-- Copyright : (c) Alexey Kuleshevich 2019-2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.Color.Space.CIE1931.XYZ+ ( pattern ColorXYZ+ , XYZ+ ) where++import Graphics.Color.Space.Internal
+ src/Graphics/Color/Space/CIE1976/LAB.hs view
@@ -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 <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Space/Internal.hs view
@@ -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 <lehins@yandex.ru>+-- 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+ #-}
+ src/Graphics/Color/Space/RGB.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE PatternSynonyms #-}+-- |+-- Module : Graphics.Color.Space.RGB+-- Copyright : (c) Alexey Kuleshevich 2019-2020+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- 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)
+ src/Graphics/Color/Space/RGB/AdobeRGB.hs view
@@ -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 <lehins@yandex.ru>+-- 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)
+ src/Graphics/Color/Space/RGB/Alternative.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE PatternSynonyms #-}+-- |+-- Module : Graphics.Color.Space.RGB.Alternative+-- Copyright : (c) Alexey Kuleshevich 2019+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Space/RGB/Alternative/CMYK.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Space/RGB/Alternative/HSI.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Space/RGB/Alternative/HSL.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Space/RGB/Alternative/HSV.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Space/RGB/Derived/AdobeRGB.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Space/RGB/Derived/SRGB.hs view
@@ -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 <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Space/RGB/ITU/Rec470.hs view
@@ -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 <lehins@yandex.ru>+-- 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)+
+ src/Graphics/Color/Space/RGB/ITU/Rec601.hs view
@@ -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 <lehins@yandex.ru>+-- 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)+
+ src/Graphics/Color/Space/RGB/ITU/Rec709.hs view
@@ -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 <lehins@yandex.ru>+-- 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
+ src/Graphics/Color/Space/RGB/Internal.hs view
@@ -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 <lehins@yandex.ru>+-- 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+-- <XYZ CIE1931 'D65:(Evaluated only once!!!+-- 0.166888, 0.185953, 0.310856)>+-- >>> srgbFromLinear $ ColorRGB 0.1 0.2 0.3+-- <XYZ CIE1931 'D65:( 0.166888, 0.185953, 0.310856)>+-- >>> rgb = ColorRGB 0.1 0.2 0.3 :: Color (SRGB 'D65) Float+-- >>> npmApply npm rgb :: Color (XYZ 'D65) Float+-- <XYZ CIE1931 'D65:( 0.166888, 0.185953, 0.310856)>+--+-- Here is a comparison with a non-liner sRGB conversion:+--+-- >>> npmApply npm (dcctf rgb) :: Color (XYZ 'D65) Float {- non-linear transformation -}+-- <XYZ CIE1931 'D65:( 0.029186, 0.031093, 0.073737)>+-- >>> toColorXYZ rgb :: Color (XYZ 'D65) Float {- non-linear transformation -}+-- <XYZ CIE1931 'D65:( 0.029186, 0.031093, 0.073737)>+--+--+-- @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 <CIExyY * D65:( 0.312700, 0.329000)>)+-- >>> Just (pixelWhitePoint @Float (ColorSRGB @Word8 1 2 3))+-- Just (WhitePoint (Chromaticity <CIExyY * D65:( 0.312700, 0.329000)>))+--+-- @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 #-}+++
+ src/Graphics/Color/Space/RGB/Luma.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Space/RGB/SRGB.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ src/Graphics/Color/Standard/RAL.hs view
@@ -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 <lehins@yandex.ru>+-- 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)
+ src/Graphics/Pixel.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}+
+ src/Graphics/Pixel/ColorSpace.hs view
@@ -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 <lehins@yandex.ru>+-- 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+-- <SRGB:( 0.000000, 0.500000, 1.000000)>+-- >>> convertPixel @AdobeRGB @_ @Word8 px+-- <AdobeRGB:( 71,127,251)>+--+-- @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 #-}
+ src/Graphics/Pixel/Internal.hs view
@@ -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 <lehins@yandex.ru>+-- 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 #-}
+ tests/Graphics/Color/Model/CMYKSpec.hs view
@@ -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)
+ tests/Graphics/Color/Model/Common.hs view
@@ -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
+ tests/Graphics/Color/Model/HSISpec.hs view
@@ -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+ ]
+ tests/Graphics/Color/Model/HSLSpec.hs view
@@ -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+ ]
+ tests/Graphics/Color/Model/HSVSpec.hs view
@@ -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+ ]
+ tests/Graphics/Color/Model/RGBSpec.hs view
@@ -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+ ]
+ tests/Graphics/Color/Space/CIE1931/IlluminantSpec.hs view
@@ -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)
+ tests/Graphics/Color/Space/CIE1976/LABSpec.hs view
@@ -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)+
+ tests/Graphics/Color/Space/Common.hs view
@@ -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)+
+ tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs view
@@ -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)
+ tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs view
@@ -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
+ tests/Graphics/Color/Space/RGB/SRGBSpec.hs view
@@ -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
+ tests/Graphics/Color/Space/YUV/YCbCrSpec.hs view
@@ -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))
+ tests/Graphics/Color/Standard/RALSpec.hs view
@@ -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+ ]+ ]
+ tests/Main.hs view
@@ -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
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ tests/doctests.hs view
@@ -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