Add more basic tests for RGBs and Illuminants

Color/Color.cabal

@@ -103,7 +103,10 @@ test-suite tests
   type:               exitcode-stdio-1.0
   hs-source-dirs:     tests
   main-is:            Main.hs
-  other-modules:      Graphics.Color.Illuminant.WikipediaSpec
+  other-modules:      Graphics.Color.Illuminant.CIE1931Spec
+                    , Graphics.Color.Illuminant.CIE1964Spec
+                    , Graphics.Color.Illuminant.Common
+                    , Graphics.Color.Illuminant.WikipediaSpec
                     , Graphics.Color.Model.Common
                     , Graphics.Color.Model.CMYKSpec
                     , Graphics.Color.Model.HSISpec
@@ -113,8 +116,12 @@ test-suite tests
                     , Graphics.Color.Model.YCbCrSpec
                     , Graphics.Color.Space.Common
                     , Graphics.Color.Space.CIE1976.LABSpec
+                    , Graphics.Color.Space.RGB.AdobeRGBSpec
                     , Graphics.Color.Space.RGB.SRGBSpec
+                    , Graphics.Color.Space.RGB.Derived.AdobeRGBSpec
                     , Graphics.Color.Space.RGB.Derived.SRGBSpec
+                    , Graphics.Color.Space.RGB.ITU.Rec470Spec
+                    , Graphics.Color.Space.RGB.ITU.Rec601Spec
                     , Graphics.Color.Space.RGB.ITU.Rec709Spec
                     , Graphics.Color.Space.RGB.Alternative.YCbCrSpec
                     , Graphics.Color.Standard.RALSpec

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

@@ -34,7 +34,6 @@ module Graphics.Color.Space.Internal
   , primaryTristimulus
   , Illuminant(..)
   , WhitePoint(.., WhitePoint)
-  , Tristimulus(..)
   , xWhitePoint
   , yWhitePoint
   , zWhitePoint
@@ -147,8 +146,9 @@ class (Typeable i, Typeable k, KnownNat (Temperature i)) => Illuminant (i :: k)
   colorTemperature = CCT (fromIntegral (natVal (Proxy :: Proxy (Temperature i))))
 
 
-newtype WhitePoint (i :: k) e = WhitePointChromaticity (Chromaticity i e)
- deriving (Eq)
+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)
@@ -163,10 +163,6 @@ 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

Color/tests/Graphics/Color/Illuminant/CIE1931Spec.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Graphics.Color.Illuminant.CIE1931Spec (spec) where
+
+import Graphics.Color.Space.Common
+import Graphics.Color.Illuminant.Common
+import Graphics.Color.Illuminant.CIE1931
+
+spec :: Spec
+spec =
+  describe "Wikipedia" $ do
+    describe "IlluminantSpec" $ do
+      illuminantSpec @'A
+      illuminantSpec @'B
+      illuminantSpec @'C
+      illuminantSpec @'D50
+      illuminantSpec @'D55
+      illuminantSpec @'D60
+      illuminantSpec @'D65
+      illuminantSpec @'D75
+      illuminantSpec @'E
+      illuminantSpec @'FL1
+      illuminantSpec @'FL2
+      illuminantSpec @'FL3
+      illuminantSpec @'FL4
+      illuminantSpec @'FL5
+      illuminantSpec @'FL6
+      illuminantSpec @'FL7
+      illuminantSpec @'FL8
+      illuminantSpec @'FL9
+      illuminantSpec @'FL10
+      illuminantSpec @'FL11
+      illuminantSpec @'FL12
+      illuminantSpec @'FL3_1
+      illuminantSpec @'FL3_2
+      illuminantSpec @'FL3_3
+      illuminantSpec @'FL3_4
+      illuminantSpec @'FL3_5
+      illuminantSpec @'FL3_6
+      illuminantSpec @'FL3_7
+      illuminantSpec @'FL3_8
+      illuminantSpec @'FL3_9
+      illuminantSpec @'FL3_10
+      illuminantSpec @'FL3_11
+      illuminantSpec @'FL3_12
+      illuminantSpec @'FL3_13
+      illuminantSpec @'FL3_14
+      illuminantSpec @'FL3_15
+      illuminantSpec @'HP1
+      illuminantSpec @'HP2
+      illuminantSpec @'HP3
+      illuminantSpec @'HP4
+      illuminantSpec @'HP5
+    describe "Derived Classes" $ do
+      let is = [A .. HP5]
+      it "Bounded" $ [minBound .. maxBound] `shouldBe` is
+      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])

Color/tests/Graphics/Color/Illuminant/CIE1964Spec.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Graphics.Color.Illuminant.CIE1964Spec (spec) where
+
+import Graphics.Color.Space.Common
+import Graphics.Color.Illuminant.Common
+import Graphics.Color.Illuminant.CIE1964
+
+spec :: Spec
+spec =
+  describe "Wikipedia" $ do
+    describe "IlluminantSpec" $ do
+      illuminantSpec @'A
+      illuminantSpec @'B
+      illuminantSpec @'C
+      illuminantSpec @'D50
+      illuminantSpec @'D55
+      illuminantSpec @'D60
+      illuminantSpec @'D65
+      illuminantSpec @'D75
+      illuminantSpec @'E
+      illuminantSpec @'FL1
+      illuminantSpec @'FL2
+      illuminantSpec @'FL3
+      illuminantSpec @'FL4
+      illuminantSpec @'FL5
+      illuminantSpec @'FL6
+      illuminantSpec @'FL7
+      illuminantSpec @'FL8
+      illuminantSpec @'FL9
+      illuminantSpec @'FL10
+      illuminantSpec @'FL11
+      illuminantSpec @'FL12
+    describe "Derived Classes" $ do
+      let is = [A .. FL12]
+      it "Bounded" $ [minBound .. maxBound] `shouldBe` is
+      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 :: [CIE1964])

Color/tests/Graphics/Color/Illuminant/Common.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Graphics.Color.Illuminant.Common
+  ( illuminantSpec
+  ) where
+
+import Data.Proxy
+import Graphics.Color.Space
+import Graphics.Color.Model.Common
+
+
+colorTemperatureExpectation ::
+     forall i. Illuminant i
+  => Expectation
+colorTemperatureExpectation =
+  round (unCCT (colorTemperature :: CCT i)) `shouldBe` natVal (Proxy :: Proxy (Temperature i))
+
+
+illuminantSpec ::
+     forall i. (Illuminant i)
+  => Spec
+illuminantSpec =
+  let wp = whitePoint :: WhitePoint i Double
+  in describe (showsType (Proxy :: Proxy i) "") $ do
+       it "colorTemperature" $ colorTemperatureExpectation @i
+       it "tristimulus to chromaticity" $
+         fromColorXYZ (whitePointTristimulus :: Color (XYZ i) Double) `epsilonEqColorDouble`
+           case wp of
+             WhitePointChromaticity (Chromaticity c) -> c
+       prop "whitePointXZ" $ forAll arbitraryElevator $ \ vY ->
+         sum (whitePointXZ vY wp) `epsilonEqDouble` vY / yWhitePoint wp

Color/tests/Graphics/Color/Illuminant/WikipediaSpec.hs

@@ -1,11 +1,13 @@
-{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications #-}
 module Graphics.Color.Illuminant.WikipediaSpec (spec) where
 
 import Data.Proxy
 import Graphics.Color.Space.Common
+import Graphics.Color.Illuminant.Common
 import Graphics.Color.Illuminant.Wikipedia
 import qualified Data.Colour.CIE as Colour
 import qualified Data.Colour.CIE.Illuminant as Colour
@@ -28,6 +30,27 @@ instance Arbitrary Degree2 where
 spec :: Spec
 spec =
   describe "Wikipedia" $ do
+    describe "IlluminantSpec" $ do
+      illuminantSpec @'A
+      illuminantSpec @'B
+      illuminantSpec @'C
+      illuminantSpec @'D50
+      illuminantSpec @'D55
+      illuminantSpec @'D65
+      illuminantSpec @'D75
+      illuminantSpec @'E
+      illuminantSpec @'F1
+      illuminantSpec @'F12
+      illuminantSpec @'F3
+      illuminantSpec @'F4
+      illuminantSpec @'F5
+      illuminantSpec @'F6
+      illuminantSpec @'F7
+      illuminantSpec @'F8
+      illuminantSpec @'F9
+      illuminantSpec @'F10
+      illuminantSpec @'F11
+      illuminantSpec @'F12
     describe "Match 'colour' package" $ do
       Colour.chromaCoords Colour.a `shouldMatch` (whitePoint :: WhitePoint 'A Double)
       Colour.chromaCoords Colour.b `shouldMatch` (whitePoint :: WhitePoint 'B Double)

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

@@ -13,6 +13,8 @@ module Graphics.Color.Model.Common
   , epsilonColorExpect
   , epsilonColorIxSpec
   , epsilonEq
+  , epsilonEqFloat
+  , epsilonEqDouble
   , epsilonEqColor
   , epsilonEqColorFloat
   , epsilonEqColorDouble
@@ -27,9 +29,9 @@ module Graphics.Color.Model.Common
   , module Test.Hspec.QuickCheck
   , module Test.QuickCheck
   , module System.Random
+  , module F
   ) where
 
-import Control.Applicative
 import Data.Proxy
 import Data.Foldable as F
 import Graphics.Color.Model
@@ -41,6 +43,8 @@ import Test.QuickCheck
 import Control.Monad
 
 
+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)
 
@@ -87,8 +91,6 @@ approxIntegralColorExpect1 ::
      (HasCallStack, ColorModel cs e, Integral e) => Color cs e -> Color cs e -> Expectation
 approxIntegralColorExpect1 = approxIntegralColorExpect 1
 
-infix 1 `approxIntegralColorExpect1`
-
 epsilonExpect ::
      (HasCallStack, Show a, RealFloat a)
   => a -- ^ Epsilon, a maximum tolerated error. Sign is ignored.
@@ -142,6 +144,23 @@ epsilonEq ::
   -> Property
 epsilonEq epsilon x y = property $ epsilonExpect epsilon x y
 
+epsilonEqDouble ::
+     Double -- ^ Expected result.
+  -> Double -- ^ Tested value.
+  -> Property
+epsilonEqDouble = epsilonEq epsilon
+  where
+    epsilon = 1e-12
+
+epsilonEqFloat ::
+     Float -- ^ Expected result.
+  -> Float -- ^ Tested value.
+  -> Property
+epsilonEqFloat = epsilonEq epsilon
+  where
+    epsilon = 1e-6
+
+
 epsilonEqColor :: (ColorModel cs e, RealFloat e) => Color cs e -> Color cs e -> Property
 epsilonEqColor = epsilonEqColorTol epsilon
   where
@@ -152,7 +171,6 @@ epsilonEqColorDouble = epsilonEqColorTol epsilon
   where
     epsilon = 1e-12
 
-
 epsilonEqColorFloat :: ColorModel cs Float => Color cs Float -> Color cs Float -> Property
 epsilonEqColorFloat = epsilonEqColorTol epsilon
   where

Color/tests/Graphics/Color/Model/YCbCrSpec.hs

@@ -7,24 +7,12 @@ module Graphics.Color.Model.YCbCrSpec (spec) where
 import Graphics.Color.Model
 import Graphics.Color.Model.Common
 import Graphics.Color.Model.RGBSpec ()
-import qualified Codec.Picture.Types as JuicyPixels
 
 instance (Elevator e, Random e) => Arbitrary (Color YCbCr e) where
   arbitrary =
     ColorYCbCr <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator
 
 spec :: Spec
 spec =
-  describe "YCbCr" $ do
+  describe "YCbCr" $
     colorModelSpec @YCbCr @Word "YCbCr"
-    -- prop "rgb2ycbcr . ycbcr2rgb" $ \(rgb :: Color RGB Double) ->
-    --   rgb `epsilonEqColor` ycbcr2rgb (rgb2ycbcr rgb)
-    -- describe "Match JuicyPixels" $ do
-    --   prop "rgb2ycbcr" $ \(rgb@(ColorRGB r g b) :: Color RGB Word8) ->
-    --     case JuicyPixels.convertPixel (JuicyPixels.PixelRGB8 r g b) of
-    --       JuicyPixels.PixelYCbCr8 y cb cr ->
-    --         toWord8 <$> rgb2ycbcr (toFloat <$> rgb) `approxIntegralColorExpect1` ColorYCbCr y cb cr
-    --   prop "ycbcr2rgb" $ \(ycbcr@(ColorYCbCr y cb cr) :: Color YCbCr Word8) ->
-    --     case JuicyPixels.convertPixel (JuicyPixels.PixelYCbCr8 y cb cr) of
-    --       JuicyPixels.PixelRGB8 r g b ->
-    --         toWord8 <$> ycbcr2rgb (toFloat <$> ycbcr) `approxIntegralColorExpect1` ColorRGB r g b

Color/tests/Graphics/Color/Space/RGB/AdobeRGBSpec.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+module Graphics.Color.Space.RGB.AdobeRGBSpec (spec, arbitraryElevator) where
+
+import Graphics.Color.Space.Common
+import Graphics.Color.Space.RGB.AdobeRGB
+
+instance (Elevator e, Random e) => Arbitrary (Color AdobeRGB e) where
+  arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator
+
+
+spec :: Spec
+spec = describe "AdobeRGB" $ do
+  colorModelSpec @AdobeRGB @Word "AdobeRGB"
+  colorSpaceLenientSpec @AdobeRGB @_ @Float 0.00001

Color/tests/Graphics/Color/Space/RGB/Alternative/YCbCrSpec.hs

@@ -9,20 +9,16 @@ import Graphics.Color.Space.Common
 import Graphics.Color.Space.RGB.SRGB
 import qualified Graphics.Color.Space.RGB.Derived.SRGB as Derived
 import Graphics.Color.Space.RGB.Alternative.YCbCr
-
-instance (Elevator e, Random e) => Arbitrary (Color SRGB e) where
-  arbitrary =
-    ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator
-
-instance (Illuminant i, Elevator e, Random e) => Arbitrary (Color (Derived.SRGB i) e) where
-  arbitrary =
-    ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator
+import Graphics.Color.Space.RGB.SRGBSpec ()
+import Graphics.Color.Space.RGB.Derived.SRGBSpec ()
 
 
 instance (Elevator e, Random e) => Arbitrary (Color (YCbCr cs) e) where
   arbitrary =
     ColorYCbCr <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator
 
+-- Accurate roundtrip to/from both XYZ and SRGB is not possible due to the nature of the
+-- algorithm.
 spec :: Spec
 spec =
   describe "YCbCr" $ do

Color/tests/Graphics/Color/Space/RGB/Derived/AdobeRGBSpec.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+module Graphics.Color.Space.RGB.Derived.AdobeRGBSpec (spec) where
+
+import Graphics.Color.Illuminant.CIE1931
+import Graphics.Color.Space.Common
+import Graphics.Color.Space.RGB.Derived.AdobeRGB
+
+instance (Elevator e, Random e, Illuminant i) => Arbitrary (Color (AdobeRGB (i :: k)) e) where
+  arbitrary = ColorRGB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator
+
+
+spec :: Spec
+spec = describe "AdobeRGB" $ do
+  colorModelSpec @(AdobeRGB 'D65) @Word "AdobeRGB"
+  colorSpaceSpec @(AdobeRGB 'D65) @_ @Float