diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Changelog for color +## 0.1.3 + +* Addition of `CMCCAT2000`. +* Rename `CIECAM02` to `CIECAT02` with a fallback synonym for backwards compatibility +* Fix `ColorSpace` instance for `Alpha cs` +* Add `ColorSpace` instances for `YCbCr cs` color spaces that have `Luma` instance: + `BT709`, `BT601_525` and `BT601_625` + ## 0.1.2 * Fix `YCbCr` conversion to derived RGB color spaces diff --git a/Color.cabal b/Color.cabal --- a/Color.cabal +++ b/Color.cabal @@ -1,5 +1,5 @@ name: Color -version: 0.1.2 +version: 0.1.3 synopsis: Color spaces and conversions between them description: Please see the README on GitHub at homepage: https://github.com/lehins/Color @@ -130,6 +130,7 @@ , Graphics.Color.Space.RGB.Alternative.HSLSpec , Graphics.Color.Space.RGB.Alternative.HSVSpec , Graphics.Color.Space.RGB.Alternative.YCbCrSpec + , Graphics.Color.SpaceSpec , Graphics.Color.Standard.RALSpec , Spec build-depends: JuicyPixels @@ -141,6 +142,8 @@ , hspec , random , vector + , massiv + , massiv-test default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Graphics/Color/Adaptation/VonKries.hs b/src/Graphics/Color/Adaptation/VonKries.hs --- a/src/Graphics/Color/Adaptation/VonKries.hs +++ b/src/Graphics/Color/Adaptation/VonKries.hs @@ -30,8 +30,12 @@ , vonKriesAdaptation , bradfordAdaptation , fairchildAdaptation - , ciecam02Adaptation + , ciecat02Adaptation + , cmccat2000Adaptation , adaptationMatrix + -- * Deprecated + , CIECAM02 + , ciecam02Adaptation ) where import Data.Coerce @@ -44,7 +48,7 @@ data VonKries = VonKries - -- ^ VonKries chromatic adaptation transform matrix + -- ^ VonKries chromatic adaptation transform -- -- >>> cat :: CAT 'VonKries Float -- CAT VonKries 'VonKries Float @@ -56,8 +60,10 @@ -- [ [ 1.859936,-1.129382, 0.219897 ] -- , [ 0.361191, 0.638812,-0.000006 ] -- , [-0.000000,-0.000000, 1.089064 ] ] + -- + -- @since 0.1.0 | Bradford - -- ^ Bradford chromatic adaptation transform matrix + -- ^ Bradford chromatic adaptation transform -- -- >>> cat :: CAT 'Bradford Float -- CAT VonKries 'Bradford Float @@ -69,8 +75,10 @@ -- [ [ 0.986993,-0.147054, 0.159963 ] -- , [ 0.432305, 0.518360, 0.049291 ] -- , [-0.008529, 0.040043, 0.968487 ] ] + -- + -- @since 0.1.0 | Fairchild - -- ^ Fairchild chromatic adaptation transform matrix + -- ^ Fairchild chromatic adaptation transform -- -- >>> cat :: CAT 'Fairchild Float -- CAT VonKries 'Fairchild Float @@ -82,21 +90,40 @@ -- [ [ 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 + -- @since 0.1.0 + | CIECAT02 + -- ^ CIECAT02 chromatic adaptation transform + -- + -- >>> cat :: CAT 'CIECAT02 Float + -- CAT VonKries 'CIECAT02 Float -- [ [ 0.732800, 0.429600,-0.162400 ] -- , [-0.703600, 1.697500, 0.006100 ] -- , [ 0.003000, 0.013600, 0.983400 ] ] - -- >>> icat :: ICAT 'CIECAM02 Float - -- ICAT VonKries 'CIECAM02 Float + -- >>> icat :: ICAT 'CIECAT02 Float + -- ICAT VonKries 'CIECAT02 Float -- [ [ 1.096124,-0.278869, 0.182745 ] -- , [ 0.454369, 0.473533, 0.072098 ] -- , [-0.009628,-0.005698, 1.015326 ] ] + -- + -- @since 0.1.3 + | CMCCAT2000 + -- ^ CMCCAT2000 chromatic adaptation transform + -- + -- >>> cat :: CAT 'CMCCAT2000 Float + -- CAT VonKries 'CMCCAT2000 Float + -- [ [ 0.798200, 0.338900,-0.137100 ] + -- , [-0.591800, 1.551200, 0.040600 ] + -- , [ 0.000800, 0.023900, 0.975300 ] ] + -- >>> icat :: ICAT 'CMCCAT2000 Float + -- ICAT VonKries 'CMCCAT2000 Float + -- [ [ 1.076450,-0.237662, 0.161212 ] + -- , [ 0.410964, 0.554342, 0.034694 ] + -- , [-0.010954,-0.013389, 1.024343 ] ] + -- + -- @since 0.1.3 --- | Chromatic adaptation transformation matrix matrix +-- | Chromatic adaptation transformation matrix newtype CAT (t :: k) e = CAT (M3x3 e) deriving (Eq) @@ -134,12 +161,16 @@ (V3 -0.8360 1.8327 0.0033) (V3 0.0357 -0.0469 1.0112)) - -instance ChromaticAdaptationTransform 'CIECAM02 where +instance ChromaticAdaptationTransform 'CIECAT02 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 ChromaticAdaptationTransform 'CMCCAT2000 where + cat = CAT (M3x3 (V3 0.7982 0.3389 -0.1371) + (V3 -0.5918 1.5512 0.0406) + (V3 0.0008 0.0239 0.9753)) + 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 = @@ -169,21 +200,52 @@ wpTest = coerce (whitePointTristimulus :: Color (XYZ it) e) wpRef = coerce (whitePointTristimulus :: Color (XYZ ir) e) +-- | `VonKries` chromatic adaptation transform. +-- +-- @since 0.1.2 vonKriesAdaptation :: ChromaticAdaptation 'VonKries it ir e => Adaptation 'VonKries it ir e vonKriesAdaptation = adaptationMatrix {-# INLINE vonKriesAdaptation #-} +-- | `Fairchild` chromatic adaptation transform. +-- +-- @since 0.1.2 fairchildAdaptation :: ChromaticAdaptation 'Fairchild it ir e => Adaptation 'Fairchild it ir e fairchildAdaptation = adaptationMatrix {-# INLINE fairchildAdaptation #-} +-- | `Bradford` chromatic adaptation transform, as defined in the +-- [CIECAM97s](https://en.wikipedia.org/wiki/Color_appearance_model#CIECAM97s) color +-- appearance model. +-- +-- @since 0.1.2 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 +-- | `CIECAT02` chromatic adaptation as defined it +-- [CIECAM02](https://en.wikipedia.org/wiki/CIECAM02) color appearance model +-- +-- @since 0.1.3 +ciecat02Adaptation :: ChromaticAdaptation 'CIECAT02 it ir e => Adaptation 'CIECAT02 it ir e +ciecat02Adaptation = adaptationMatrix +{-# INLINE ciecat02Adaptation #-} + +-- | `CMCCAT2000` chromatic adaptation. Predecessor of `CIECAT02`. as defined it +-- [CIECAM02](https://en.wikipedia.org/wiki/CIECAM02) color appearance model +-- +-- @since 0.1.3 +cmccat2000Adaptation :: ChromaticAdaptation 'CMCCAT2000 it ir e => Adaptation 'CIECAT02 it ir e +cmccat2000Adaptation = adaptationMatrix +{-# INLINE cmccat2000Adaptation #-} + +type CIECAM02 = 'CIECAT02 +{-# DEPRECATED CIECAM02 "In favor of a proper name 'CIECAT02'" #-} + +ciecam02Adaptation :: ChromaticAdaptation CIECAM02 it ir e => Adaptation CIECAM02 it ir e ciecam02Adaptation = adaptationMatrix {-# INLINE ciecam02Adaptation #-} +{-# DEPRECATED ciecam02Adaptation "In favor of a proper name 'ciecat02Adaptation'" #-} -- | This function allows conversion of a color between any two color spaces. It uses a -- very common `VonKries` chromatic adaptation transform with `Bradford` matrix. One of @@ -195,25 +257,3 @@ convert :: (ColorSpace cs' i' e', ColorSpace cs i e) => Color cs' e' -> Color cs e convert = convertElevatedWith (adaptationMatrix @'Bradford @_ @_ @Double) {-# INLINE convert #-} - - --- RAL adopted: Daffodil yellow --- toWord8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptation :: VonKriesAdaptation Bradford D50a D65 Float) (toColorXYZ (ColorLAB 66.5 27.308 80.402 :: Color (LAB D50a) Float) :: Color XYZ Float)) :: Color SRGB Float) --- - - --- --- toWord8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptation :: VonKriesAdaptation Bradford D50a D65 Double) (toColorXYZ (ColorLAB 83.353 3.462 75.829 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double) --- - - --- -- Green beige --- toWord8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptation :: VonKriesAdaptation Bradford D50a D65 Double) (toColorXYZ (ColorLAB 76.022 (-0.366) 27.636 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double) --- - --- From srgb spec --- srgbVonKries :: VonKriesAdaptationMatrix t it ir Double --- srgbVonKries = VonKriesAdaptationMatrix $ M3x3 --- (V3 1.047844353856414 0.022898981050086 -0.050206647741605) --- (V3 0.029549007606644 0.990508028941971 -0.017074711360960) --- (V3 -0.009250984365223 0.015072338237051 0.751717835079977) diff --git a/src/Graphics/Color/Illuminant/CIE1931.hs b/src/Graphics/Color/Illuminant/CIE1931.hs --- a/src/Graphics/Color/Illuminant/CIE1931.hs +++ b/src/Graphics/Color/Illuminant/CIE1931.hs @@ -546,7 +546,7 @@ -- -- All of the values were taken directly from: /CIE15: Technical Report: Colorimetry, 3rd edition/ -- --- ![colorMatchingFunctions](files/colorMatchingFunctions.png) +-- ![colorMatchingFunctions](files/colorMatchingFunctions.svg) -- -- @since 0.1.2 xyzColorMatchingFunctions :: [(Double, V3 Double, V2 Double)] diff --git a/src/Graphics/Color/Model/Alpha.hs b/src/Graphics/Color/Model/Alpha.hs --- a/src/Graphics/Color/Model/Alpha.hs +++ b/src/Graphics/Color/Model/Alpha.hs @@ -16,6 +16,7 @@ module Graphics.Color.Model.Alpha ( Alpha , Opaque + , Transparent , addAlpha , getAlpha , setAlpha @@ -85,21 +86,26 @@ (==) (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 +instance (ColorModel cs e, cs ~ Opaque (Alpha cs), Alpha cs ~ Transparent 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 family Transparent cs where + Transparent (Alpha cs) = TypeError ('Text "Nested alpha channels are not allowed") + Transparent cs = Alpha cs + +instance (ColorModel cs e, cs ~ Opaque (Alpha cs), Alpha cs ~ Transparent 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':) + showsColorModelName _ = ("Alpha (" ++) . showsColorModelName (Proxy :: Proxy (Color cs e)) . (')':) instance Functor (Color cs) => Functor (Color (Alpha cs)) where diff --git a/src/Graphics/Color/Model/Y.hs b/src/Graphics/Color/Model/Y.hs --- a/src/Graphics/Color/Model/Y.hs +++ b/src/Graphics/Color/Model/Y.hs @@ -106,4 +106,4 @@ newtype Weights e = Weights { unWeights :: V3 e - } + } deriving (Eq, Num, Show, Fractional, Floating, Functor) diff --git a/src/Graphics/Color/Space/Internal.hs b/src/Graphics/Color/Space/Internal.hs --- a/src/Graphics/Color/Space/Internal.hs +++ b/src/Graphics/Color/Space/Internal.hs @@ -64,7 +64,7 @@ import GHC.TypeNats import Data.Kind -class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e, Typeable (Opaque cs)) => +class (Illuminant i, ColorModel (BaseModel cs) e, ColorModel cs e) => ColorSpace cs (i :: k) e | cs -> i where type BaseModel cs :: Type @@ -106,21 +106,29 @@ instance ( ColorSpace cs i e - , Opaque (Alpha cs) ~ cs - , Opaque (Alpha (BaseModel cs)) ~ BaseModel cs) => + , ColorSpace (BaseSpace cs) i e + , ColorSpace (Alpha (BaseSpace cs)) i e + , cs ~ Opaque (Alpha cs) + , Alpha cs ~ Transparent cs + , BaseModel cs ~ Opaque (Alpha (BaseModel cs)) + , Alpha (BaseModel cs) ~ Transparent (BaseModel cs) + ) => ColorSpace (Alpha cs) i e where type BaseModel (Alpha cs) = Alpha (BaseModel cs) - type BaseSpace (Alpha cs) = cs - + type BaseSpace (Alpha cs) = Alpha (BaseSpace cs) toBaseModel = modifyOpaque toBaseModel {-# INLINE toBaseModel #-} fromBaseModel = modifyOpaque fromBaseModel {-# INLINE fromBaseModel #-} + toColorXYZ = toColorXYZ . dropAlpha + {-# INLINE toColorXYZ #-} + fromColorXYZ = (`addAlpha` maxValue) . fromColorXYZ + {-# INLINE fromColorXYZ #-} luminance = luminance . dropAlpha {-# INLINE luminance #-} - toBaseSpace = dropAlpha + toBaseSpace = modifyOpaque toBaseSpace {-# INLINE toBaseSpace #-} - fromBaseSpace c = Alpha c maxValue + fromBaseSpace = modifyOpaque fromBaseSpace {-# INLINE fromBaseSpace #-} -- | This is a data type that encodes a data point on the chromaticity diagram diff --git a/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs b/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs --- a/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs +++ b/src/Graphics/Color/Space/RGB/Alternative/YCbCr.hs @@ -39,6 +39,8 @@ import qualified Graphics.Color.Model.YCbCr as CM import Graphics.Color.Space import Graphics.Color.Space.RGB.SRGB +import Graphics.Color.Space.RGB.ITU.Rec601 +import Graphics.Color.Space.RGB.ITU.Rec709 import Graphics.Color.Space.RGB.Luma -- | `YCbCr` representation for some (@`RedGreenBlue` cs i@) color space @@ -93,6 +95,39 @@ toBaseSpace = fmap fromRealFloat . ycbcr2srgb . fmap toFloat {-# INLINE toBaseSpace #-} fromBaseSpace = fmap fromRealFloat . srgb2ycbcr . fmap toFloat + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + +-- | `YCbCr` representation for `BT601_525` color space +instance Elevator e => ColorSpace (YCbCr BT601_525) D65 e where + type BaseModel (YCbCr BT601_525) = CM.YCbCr + type BaseSpace (YCbCr BT601_525) = BT601_525 + toBaseSpace = fmap fromDouble . fromColorYCbCr + {-# INLINE toBaseSpace #-} + fromBaseSpace = fmap fromDouble . toColorYCbCr + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + +-- | `YCbCr` representation for `BT601_625` color space +instance Elevator e => ColorSpace (YCbCr BT601_625) D65 e where + type BaseModel (YCbCr BT601_625) = CM.YCbCr + type BaseSpace (YCbCr BT601_625) = BT601_625 + toBaseSpace = fmap fromDouble . fromColorYCbCr + {-# INLINE toBaseSpace #-} + fromBaseSpace = fmap fromDouble . toColorYCbCr + {-# INLINE fromBaseSpace #-} + luminance = luminance . toBaseSpace + {-# INLINE luminance #-} + +-- | `YCbCr` representation for `BT709` color space +instance Elevator e => ColorSpace (YCbCr BT709) D65 e where + type BaseModel (YCbCr BT709) = CM.YCbCr + type BaseSpace (YCbCr BT709) = BT709 + toBaseSpace = fmap fromDouble . fromColorYCbCr + {-# INLINE toBaseSpace #-} + fromBaseSpace = fmap fromDouble . toColorYCbCr {-# INLINE fromBaseSpace #-} luminance = luminance . toBaseSpace {-# INLINE luminance #-} diff --git a/src/Graphics/Color/Space/RGB/Luma.hs b/src/Graphics/Color/Space/RGB/Luma.hs --- a/src/Graphics/Color/Space/RGB/Luma.hs +++ b/src/Graphics/Color/Space/RGB/Luma.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -9,19 +10,19 @@ {-# LANGUAGE TypeFamilies #-} -- | -- Module : Graphics.Color.Space.RGB.Luma --- Copyright : (c) Alexey Kuleshevich 2018-2019 +-- Copyright : (c) Alexey Kuleshevich 2018-2020 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental -- Portability : non-portable -- module Graphics.Color.Space.RGB.Luma - ( Y' - -- * Constructors for Luma. - , pattern Y' - , Color + ( -- * Luma + pattern Y' + , Y' , Luma(..) , Weight(..) + , Weights(..) , rgbLuma , rgbLumaWeights ) where @@ -109,7 +110,7 @@ newtype Weight cs e = Weight { unWeight :: e - } deriving (Eq, Show, Num, Fractional, Floating) + } deriving (Eq, Show, Num, Fractional, Floating, Functor) rgbLumaWeights :: diff --git a/tests/Graphics/Color/Illuminant/CIE1931Spec.hs b/tests/Graphics/Color/Illuminant/CIE1931Spec.hs --- a/tests/Graphics/Color/Illuminant/CIE1931Spec.hs +++ b/tests/Graphics/Color/Illuminant/CIE1931Spec.hs @@ -60,7 +60,26 @@ it "Enum" $ forM_ is $ \ i -> toEnum (fromEnum i) `shouldBe` i it "Read . Show" $ forM_ is $ \ i -> read (show i) `shouldBe` i it "Read . Show" $ read (show is) `shouldBe` (is :: [CIE1931]) - + describe "Data" $ do + describe "Wavelength is in 5nm intervals" $ do + it "spectralPowerDistributions" $ + map fst spectralPowerDistributions `shouldBe` + map fromIntegral [300, 305 .. 830 :: Int] + it "xyzColorMatchingFunctions" $ + [w | (w, _, _) <- xyzColorMatchingFunctions] `shouldBe` + map fromIntegral [380, 385 .. 780 :: Int] + describe "Sum" $ do + it "spectralPowerDistributions" $ + epsilonFoldableExpect epsilon (sum (map snd spectralPowerDistributions)) + (V3 8715.51 890.13 374.95) + it "xyzColorMatchingFunctions (x̄(λ) ȳ(λ) z̄(λ))" $ + epsilonFoldableExpect epsilon (sum [xyz | (_, xyz, _) <- xyzColorMatchingFunctions]) + (V3 21.371524 21.371327 21.37154) + it "xyzColorMatchingFunctions (x(λ) z(λ))" $ + epsilonFoldableExpect epsilon (sum [xy | (_, _, xy) <- xyzColorMatchingFunctions]) + (V2 35.7978 24.58414) + where + epsilon = 1e-12 daylightChromaticityY :: RealFloat a => a -> a daylightChromaticityY x = 2.87 * x - 3 * x ^ (2 :: Int) - 0.275 diff --git a/tests/Graphics/Color/Model/Common.hs b/tests/Graphics/Color/Model/Common.hs --- a/tests/Graphics/Color/Model/Common.hs +++ b/tests/Graphics/Color/Model/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -10,6 +11,7 @@ , matchListsWith , expectSameLength , epsilonExpect + , epsilonFoldableExpect , epsilonColorExpect , epsilonColorIxSpec , epsilonEq @@ -32,21 +34,32 @@ , module F ) where -import Data.Proxy +import Prelude as P +import Control.Monad as M import Data.Foldable as F +import Data.Massiv.Array as A +import Data.Proxy import Graphics.Color.Model import System.Random import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit (assertBool) +import Test.Massiv.Array.Mutable import Test.QuickCheck -import Control.Monad +instance (Random e, ColorModel cs e, Arbitrary (Color cs e)) => Arbitrary (Color (Alpha cs) e) where + arbitrary = addAlpha <$> arbitrary <*> arbitraryElevator +instance (ColorModel cs e, CoArbitrary (Components cs e)) => CoArbitrary (Color cs e) where + coarbitrary c = coarbitrary (toComponents c) + +instance (Function (Components cs e), ColorModel cs e) => Function (Color cs e) where + function = functionMap toComponents fromComponents + infix 1 `epsilonEqFloat`, `epsilonEqDouble`, `approxIntegralColorExpect1` izipWithM_ :: Applicative m => (Int -> a -> b -> m c) -> [a] -> [b] -> m () -izipWithM_ f xs = zipWithM_ (uncurry f) (zip [0..] xs) +izipWithM_ f xs = zipWithM_ (uncurry f) (P.zip [0..] xs) -- | Match to lists exactly element-by-element with an expectation. @@ -98,7 +111,7 @@ -> a -- ^ Tested value. -> Expectation epsilonExpect epsilon x y = - forM_ (epsilonMaybeEq epsilon x y) $ \errMsg -> + M.forM_ (epsilonMaybeEq epsilon x y) $ \errMsg -> expectationFailure $ "Expected: " ++ show x ++ " but got: " ++ show y ++ "\n " ++ errMsg @@ -120,10 +133,14 @@ epsilonColorExpect :: (HasCallStack, ColorModel cs e, RealFloat e) => e -> Color cs e -> Color cs e -> Expectation -epsilonColorExpect epsilon x y = - forM_ (zipWithM (epsilonMaybeEq epsilon) (F.toList x) (F.toList y)) $ \errMsgs -> +epsilonColorExpect = epsilonFoldableExpect + +epsilonFoldableExpect :: + (HasCallStack, Foldable f, Show (f e), Show e, RealFloat e) => e -> f e -> f e -> Expectation +epsilonFoldableExpect epsilon x y = + M.forM_ (zipWithM (epsilonMaybeEq epsilon) (F.toList x) (F.toList y)) $ \errMsgs -> expectationFailure $ - "Expected: " ++ show x ++ " but got: " ++ show y ++ "\n" ++ unlines (map (" " ++) errMsgs) + "Expected: " ++ show x ++ " but got: " ++ show y ++ "\n" ++ unlines (P.map (" " ++) errMsgs) epsilonColorIxSpec :: (HasCallStack, ColorModel cs e, RealFloat e) @@ -195,9 +212,21 @@ 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 :: + forall cs e. + ( ColorModel cs e + , Function (Components cs e) + , CoArbitrary (Components cs e) + , Arbitrary (Color cs e) + ) + => String + -> Spec colorModelSpec name = describe "ColorModel" $ do toFromComponentsSpec @cs @e it "Model Name" $ showsColorModelName (Proxy :: Proxy (Color cs e)) "" `shouldStartWith` name + modifyMaxSuccess (`div` 10) $ describe "Array" $ do + describe "Storable" $ + mutableSpec @S @Ix1 @(Color cs e) + describe "Unboxed" $ + mutableSpec @U @Ix1 @(Color cs e) diff --git a/tests/Graphics/Color/Space/CIE1976/LABSpec.hs b/tests/Graphics/Color/Space/CIE1976/LABSpec.hs --- a/tests/Graphics/Color/Space/CIE1976/LABSpec.hs +++ b/tests/Graphics/Color/Space/CIE1976/LABSpec.hs @@ -23,7 +23,7 @@ spec :: Spec spec = describe "LAB" $ do colorModelSpec @(LAB 'D65) @Word "LAB" - colorSpaceLenientSpec @(LAB 'D65) @_ @Double 1e-10 + colorSpaceLenientSpec @(LAB 'D65) @Double 1e-10 describe "Same as colour package" $ do prop "lab2srgb" $ \lab@(ColorLAB l' a' b' :: Color (LAB 'W.D65) Double) -> case Colour.toSRGB (Colour.cieLAB Colour.d65 l' a' b') of diff --git a/tests/Graphics/Color/Space/Common.hs b/tests/Graphics/Color/Space/Common.hs --- a/tests/Graphics/Color/Space/Common.hs +++ b/tests/Graphics/Color/Space/Common.hs @@ -27,7 +27,7 @@ prop_toFromColorXYZ :: - forall cs i e. (ColorSpace cs i e, RealFloat e) + forall cs e i. (ColorSpace cs i e, RealFloat e) => Color cs e -> Property prop_toFromColorXYZ c = c `epsilonEqColor` fromColorXYZ (toColorXYZ c :: Color (XYZ i) Double) @@ -35,26 +35,26 @@ -- 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) + forall cs e i. (ColorSpace cs i e, RealFloat e) => e -> Color cs e -> Property prop_toFromLenientColorXYZ epsilon c = epsilonEqColorTol epsilon c (fromColorXYZ (toColorXYZ c :: Color (XYZ i) Double)) -prop_LuminanceColorXYZ :: forall cs i e . ColorSpace cs i e => Color cs e -> Property +prop_LuminanceColorXYZ :: forall cs e i . ColorSpace cs i e => Color cs e -> Property prop_LuminanceColorXYZ c = (luminance c :: Color (Y i) Float) `epsilonEqColor` luminance (toColorXYZ c :: Color (XYZ i) Float) prop_toFromBaseSpace :: - forall cs i e. (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, RealFloat e) + forall cs e i. (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, RealFloat e) => Color cs e -> Property prop_toFromBaseSpace c = c `epsilonEqColor` fromBaseSpace (toBaseSpace c) prop_toFromBaseSpaceLenient :: - forall cs i e. (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, RealFloat e) + forall cs e i. (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, RealFloat e) => e -> Color cs e -> Property @@ -62,37 +62,37 @@ prop_toFromBaseModel :: - forall cs i e. ColorSpace cs i e + forall cs e i. ColorSpace cs i e => Color cs e -> Property prop_toFromBaseModel c = c === fromBaseModel (toBaseModel c) colorSpaceCommonSpec :: - forall cs i e. + forall cs e i. (Arbitrary (Color cs e), ColorSpace cs i e) => Spec -> Spec colorSpaceCommonSpec extra = describe "ColorSpace" $ do - prop "luminance . toColorXYZ" $ prop_LuminanceColorXYZ @cs @i @e - prop "toFromBaseModel" $ prop_toFromBaseModel @cs @i @e + prop "luminance . toColorXYZ" $ prop_LuminanceColorXYZ @cs @e @i + prop "toFromBaseModel" $ prop_toFromBaseModel @cs @e @i extra colorSpaceSpec :: - forall cs i e. + forall cs e i. (Arbitrary (Color cs e), ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, RealFloat e) => Spec colorSpaceSpec = - colorSpaceCommonSpec @cs @i @e $ do - prop "toFromBaseSpace" $ prop_toFromBaseSpace @cs @i @e - prop "toFromColorXYZ" $ prop_toFromColorXYZ @cs @i @e + colorSpaceCommonSpec @cs @e @i $ do + prop "toFromBaseSpace" $ prop_toFromBaseSpace @cs @e @i + prop "toFromColorXYZ" $ prop_toFromColorXYZ @cs @e @i colorSpaceLenientSpec :: - forall cs i e. + forall cs e i. (Arbitrary (Color cs e), ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, RealFloat e) => e -> Spec colorSpaceLenientSpec tol = let tolStr = "(lenient=" ++ show tol ++ ")" - in colorSpaceCommonSpec @cs @i @e $ do - prop ("toFromBaseSpace " ++ tolStr) $ prop_toFromBaseSpaceLenient @cs @i @e tol - prop ("toFromColorXYZ " ++ tolStr) $ prop_toFromLenientColorXYZ @cs @i @e tol + in colorSpaceCommonSpec @cs @e @i $ do + prop ("toFromBaseSpace " ++ tolStr) $ prop_toFromBaseSpaceLenient @cs @e @i tol + prop ("toFromColorXYZ " ++ tolStr) $ prop_toFromLenientColorXYZ @cs @e @i tol diff --git a/tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs b/tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs --- a/tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs +++ b/tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs @@ -12,4 +12,4 @@ spec :: Spec spec = describe "AdobeRGB" $ do colorModelSpec @AdobeRGB @Word "AdobeRGB" - colorSpaceLenientSpec @AdobeRGB @_ @Float 0.00001 + colorSpaceLenientSpec @AdobeRGB @Float 0.00001 diff --git a/tests/Graphics/Color/Space/RGB/Alternative/CMYKSpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/CMYKSpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/CMYKSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/CMYKSpec.hs @@ -19,7 +19,7 @@ spec = describe "CMYK" $ do colorModelSpec @(CMYK (Derived.SRGB D65)) @Word "CMYK" - colorSpaceCommonSpec @(CMYK (Derived.SRGB D65)) @_ @Double $ pure () + colorSpaceCommonSpec @(CMYK (Derived.SRGB D65)) @Double $ pure () -- Arbitrary inverse CMYKtoSRGB is not true. prop "sRGBtoCMYK" $ \ (srgb :: Color (Derived.SRGB D65) Double) -> toBaseSpace (fromBaseSpace srgb :: Color (CMYK (Derived.SRGB D65)) Double) diff --git a/tests/Graphics/Color/Space/RGB/Alternative/HSISpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/HSISpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/HSISpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/HSISpec.hs @@ -18,4 +18,4 @@ describe "HSI" $ do describe "Derived-sRGB" $ do colorModelSpec @(HSI (Derived.SRGB D65)) @Word "HSI" - colorSpaceSpec @(HSI (Derived.SRGB D65)) @_ @Double + colorSpaceSpec @(HSI (Derived.SRGB D65)) @Double diff --git a/tests/Graphics/Color/Space/RGB/Alternative/HSLSpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/HSLSpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/HSLSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/HSLSpec.hs @@ -18,4 +18,4 @@ describe "HSL" $ do describe "Derived-sRGB" $ do colorModelSpec @(HSL (Derived.SRGB D65)) @Word "HSL" - colorSpaceSpec @(HSL (Derived.SRGB D65)) @_ @Double + colorSpaceSpec @(HSL (Derived.SRGB D65)) @Double diff --git a/tests/Graphics/Color/Space/RGB/Alternative/HSVSpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/HSVSpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/HSVSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/HSVSpec.hs @@ -18,4 +18,4 @@ describe "HSV" $ do describe "Derived-sRGB" $ do colorModelSpec @(HSV (Derived.SRGB D65)) @Word "HSV" - colorSpaceSpec @(HSV (Derived.SRGB D65)) @_ @Double + colorSpaceSpec @(HSV (Derived.SRGB D65)) @Double diff --git a/tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs b/tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs --- a/tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs @@ -24,10 +24,10 @@ describe "YCbCr" $ do describe "sRGB" $ do colorModelSpec @(YCbCr SRGB) @Word "YCbCr" - colorSpaceCommonSpec @(YCbCr SRGB) @_ @Double $ pure () + colorSpaceCommonSpec @(YCbCr SRGB) @Double $ pure () describe "Derived-sRGB" $ do colorModelSpec @(YCbCr (Derived.SRGB D65)) @Word "YCbCr" - colorSpaceCommonSpec @(YCbCr (Derived.SRGB D65)) @_ @Double $ pure () + colorSpaceCommonSpec @(YCbCr (Derived.SRGB D65)) @Double $ pure () prop "toColorYCbCr . toColorYCbCr" $ \(rgb :: Color (Derived.SRGB D65) Double) -> rgb `epsilonEqColor` fromColorYCbCr (toColorYCbCr rgb :: Color (YCbCr (Derived.SRGB D65)) Double) diff --git a/tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs b/tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs --- a/tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs @@ -17,4 +17,4 @@ spec :: Spec spec = describe "AdobeRGB" $ do colorModelSpec @(AdobeRGB 'D65) @Word "AdobeRGB" - colorSpaceSpec @(AdobeRGB 'D65) @_ @Float + colorSpaceSpec @(AdobeRGB 'D65) @Float diff --git a/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs b/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs --- a/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs +++ b/tests/Graphics/Color/Space/RGB/Derived/SRGBSpec.hs @@ -21,7 +21,7 @@ spec :: Spec spec = describe "SRGB" $ do colorModelSpec @(SRGB 'D65) @Word "SRGB" - colorSpaceSpec @(SRGB 'D65) @_ @Float + colorSpaceSpec @(SRGB 'D65) @Float describe "Same as colour package" $ do prop "xyz2srgb" $ \xyz@(ColorXYZ x y z :: Color (XYZ 'W.D65) Double) -> case Colour.toSRGB (Colour.cieXYZ x y z) of diff --git a/tests/Graphics/Color/Space/RGB/ITU/Rec470Spec.hs b/tests/Graphics/Color/Space/RGB/ITU/Rec470Spec.hs --- a/tests/Graphics/Color/Space/RGB/ITU/Rec470Spec.hs +++ b/tests/Graphics/Color/Space/RGB/ITU/Rec470Spec.hs @@ -18,7 +18,7 @@ spec = do describe "Rec470 (525)" $ do colorModelSpec @BT470_525 @Word "BT470_525" - colorSpaceSpec @BT470_525 @_ @Float + colorSpaceSpec @BT470_525 @Float describe "Rec470 (625)" $ do colorModelSpec @BT470_625 @Word "BT470_625" - colorSpaceSpec @BT470_625 @_ @Float + colorSpaceSpec @BT470_625 @Float diff --git a/tests/Graphics/Color/Space/RGB/ITU/Rec601Spec.hs b/tests/Graphics/Color/Space/RGB/ITU/Rec601Spec.hs --- a/tests/Graphics/Color/Space/RGB/ITU/Rec601Spec.hs +++ b/tests/Graphics/Color/Space/RGB/ITU/Rec601Spec.hs @@ -18,7 +18,7 @@ spec = do describe "Rec601 (525)" $ do colorModelSpec @BT601_525 @Word "BT601_525" - colorSpaceSpec @BT601_525 @_ @Float + colorSpaceSpec @BT601_525 @Float describe "Rec601 (625)" $ do colorModelSpec @BT601_625 @Word "BT601_625" - colorSpaceSpec @BT601_625 @_ @Float + colorSpaceSpec @BT601_625 @Float diff --git a/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs b/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs --- a/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs +++ b/tests/Graphics/Color/Space/RGB/ITU/Rec709Spec.hs @@ -15,4 +15,4 @@ spec = describe "Rec709" $ do colorModelSpec @BT709 @Word "BT709" -- Roundrtrip is not always very accurate, eg: 8.115324539550295e-2 /= 8.140132075907752e-2 - colorSpaceLenientSpec @BT709 @_ @Float 5e-4 + colorSpaceLenientSpec @BT709 @Float 5e-4 diff --git a/tests/Graphics/Color/Space/RGB/SRGBSpec.hs b/tests/Graphics/Color/Space/RGB/SRGBSpec.hs --- a/tests/Graphics/Color/Space/RGB/SRGBSpec.hs +++ b/tests/Graphics/Color/Space/RGB/SRGBSpec.hs @@ -12,4 +12,4 @@ spec :: Spec spec = describe "SRGB" $ do colorModelSpec @SRGB @Word "SRGB" - colorSpaceLenientSpec @SRGB @_ @Float 0.001 + colorSpaceLenientSpec @SRGB @Float 0.001 diff --git a/tests/Graphics/Color/SpaceSpec.hs b/tests/Graphics/Color/SpaceSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Graphics/Color/SpaceSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} +module Graphics.Color.SpaceSpec (spec) where + +import Graphics.Color.Illuminant.CIE1931 +import Graphics.Color.Space.Common + + +instance (Elevator e, Random e) => Arbitrary (Color (CIExyY i) e) where + arbitrary = ColorCIExy <$> arbitraryElevator <*> arbitraryElevator + + +spec :: Spec +spec = do + describe "XYZ" $ do + colorModelSpec @(XYZ 'E) @Word "XYZ" + colorSpaceSpec @(XYZ 'E) @Double + describe "Alpha XYZ" $ do + colorModelSpec @(Alpha (XYZ 'FL1)) @Word "Alpha (XYZ" + colorSpaceSpec @(Alpha (XYZ 'FL1)) @Double + describe "CIExyY" $ do + colorModelSpec @(CIExyY 'D50) @Word "CIExyY" + colorSpaceSpec @(CIExyY 'D50) @Double