Addition of Wikipedia 2 degree illuminants. Addition of `convertColor…

…` and `convertColorFloat`. More tests and doc. A very good comparison to colour package

Color/CHANGELOG.md

@@ -1,5 +1,10 @@
 # Changelog for color
 
-## 0.0.0
+## 0.1.1
+
+* Addition of `Graphics.Color.Illuminant.Wikipedia` module
+* Addition of `convertColor` and `convertColorFloat` functions
+
+## 0.1.0
 
 Initial alpha release

Color/Color.cabal

@@ -40,6 +40,7 @@ library
                      , Graphics.Color.Illuminant.ICC.PCS
                      , Graphics.Color.Illuminant.ITU.Rec470
                      , Graphics.Color.Illuminant.ITU.Rec601
+                     , Graphics.Color.Illuminant.Wikipedia
                      , Graphics.Color.Model
                      , Graphics.Color.Space
                      -- , Graphics.Color.Space.CIE1931.RGB
@@ -102,14 +103,14 @@ test-suite tests
   type:               exitcode-stdio-1.0
   hs-source-dirs:     tests
   main-is:            Main.hs
-  other-modules:      Graphics.Color.Model.Common
+  other-modules:      Graphics.Color.Illuminant.WikipediaSpec
+                    , 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

Color/src/Graphics/Color/Adaptation.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE TypeFamilies #-}
 -- |
 -- Module      : Graphics.Color.Adaptation
 -- Copyright   : (c) Alexey Kuleshevich 2019-2020

Color/src/Graphics/Color/Illuminant/CIE1931.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE DataKinds #-}
 -- |
 -- Module      : Graphics.Color.Illuminant.CIE1931
--- Copyright   : (c) Alexey Kuleshevich 2019
+-- Copyright   : (c) Alexey Kuleshevich 2019-2020
 -- License     : BSD3
 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
 -- Stability   : experimental
@@ -383,7 +383,7 @@ data CIE1931
   -- ^ High pressure metal halide lamp
   | HP5
   -- ^ High pressure metal halide lamp
-  deriving (Eq, Show, Enum)
+  deriving (Eq, Show, Read, Enum, Bounded)
 
 -- -- | Academy Color Encoding System
 -- data ACES =

Color/src/Graphics/Color/Illuminant/CIE1964.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE TypeFamilies #-}
 -- |
 -- Module      : Graphics.Color.Illuminant.CIE1964
--- Copyright   : (c) Alexey Kuleshevich 2019
+-- Copyright   : (c) Alexey Kuleshevich 2019-2020
 -- License     : BSD3
 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
 -- Stability   : experimental
@@ -208,4 +208,4 @@ data CIE1964
   -- /Note/ - Takes precedence over other F illuminants
   | FL12
   -- ^ Philips TL83, Ultralume 30
-  deriving (Eq, Show, Enum)
+  deriving (Eq, Show, Read, Enum, Bounded)

Color/src/Graphics/Color/Illuminant/Wikipedia.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NegativeLiterals #-}
+{-# LANGUAGE DataKinds #-}
+-- |
+-- Module      : Graphics.Color.Illuminant.Wikipedia
+-- Copyright   : (c) Alexey Kuleshevich 2019-2020
+-- License     : BSD3
+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
+-- Stability   : experimental
+-- Portability : non-portable
+--
+module Graphics.Color.Illuminant.Wikipedia
+  ( Degree2(..)
+  ) where
+
+import Graphics.Color.Space.Internal
+
+-- | @[x=0.44757, y=0.40745]@ - 2° Observer - Wikipedia
+instance Illuminant 'A   where
+  type Temperature 'A = 2856
+  whitePoint = WhitePoint 0.44757 0.40745
+
+-- | @[x=0.34842, y=0.35161]@ - 2° Observer - Wikipedia
+instance Illuminant 'B   where
+  type Temperature 'B = 4874
+  whitePoint = WhitePoint 0.34842 0.35161
+
+-- | @[x=0.31006, y=0.31616]@ - 2° Observer - Wikipedia
+instance Illuminant 'C   where
+  type Temperature 'C = 6774
+  whitePoint = WhitePoint 0.31006 0.31616
+
+-- | @[x=0.34567, y=0.35850]@ - 2° Observer - Wikipedia
+instance Illuminant 'D50 where
+  type Temperature 'D50 = 5003
+  whitePoint = WhitePoint 0.34567 0.35850
+
+-- | @[x=0.33242, y=0.34743]@ - 2° Observer - Wikipedia
+instance Illuminant 'D55 where
+  type Temperature 'D55 = 5503
+  whitePoint = WhitePoint 0.33242 0.34743
+
+-- | @[x=0.31271, y=0.32901]@ - 2° Observer - Wikipedia
+instance Illuminant 'D65 where
+  type Temperature 'D65 = 6504
+  whitePoint = WhitePoint 0.31271 0.32902
+
+-- | @[x=0.29902, y=0.31485]@ - 2° Observer - Wikipedia
+instance Illuminant 'D75 where
+  type Temperature 'D75 = 7504
+  whitePoint = WhitePoint 0.29902 0.31485
+
+-- | @[x=1/3, y=1/3]@ - 2° Observer - Wikipedia
+instance Illuminant 'E   where
+  type Temperature 'E = 5454
+  whitePoint = WhitePoint (1 / 3) (1 / 3)
+
+
+-- | @[x=0.31310, y=0.33727]@ - 2° Observer - Wikipedia
+instance Illuminant 'F1  where
+  type Temperature 'F1 = 6430
+  whitePoint = WhitePoint 0.31310 0.33727
+
+-- | @[x=0.37208, y=0.375129@ - 2° Observer - Wikipedia
+instance Illuminant 'F2  where
+  type Temperature 'F2 = 4230
+  whitePoint = WhitePoint 0.37208 0.37529
+
+-- | @[x=0.40910, y=0.39430]@ - 2° Observer - Wikipedia
+instance Illuminant 'F3  where
+  type Temperature 'F3 = 3450
+  whitePoint = WhitePoint 0.40910 0.39430
+
+-- | @[x=0.44018, y=0.40329]@ - 2° Observer - Wikipedia
+instance Illuminant 'F4  where
+  type Temperature 'F4 = 2940
+  whitePoint = WhitePoint 0.44018 0.40329
+
+-- | @[x=0.31379, y=0.34531]@ - 2° Observer - Wikipedia
+instance Illuminant 'F5  where
+  type Temperature 'F5 = 6350
+  whitePoint = WhitePoint 0.31379 0.34531
+
+-- | @[x=0.37790, y=0.38835]@ - 2° Observer - Wikipedia
+instance Illuminant 'F6  where
+  type Temperature 'F6 = 4150
+  whitePoint = WhitePoint 0.37790 0.38835
+
+-- | @[x=0.31292, y=0.32933]@ - 2° Observer - Wikipedia
+instance Illuminant 'F7  where
+  type Temperature 'F7 = 6500
+  whitePoint = WhitePoint 0.31292 0.32933
+
+-- | @[x=0.34588, y=0.35875]@ - 2° Observer - Wikipedia
+instance Illuminant 'F8  where
+  type Temperature 'F8 = 5000
+  whitePoint = WhitePoint 0.34588 0.35875
+
+-- | @[x=0.37417, y=0.37281]@ - 2° Observer - Wikipedia
+instance Illuminant 'F9  where
+  type Temperature 'F9 = 4150
+  whitePoint = WhitePoint 0.37417 0.37281
+
+-- | @[x=0.34609, y=0.35986]@ - 2° Observer - Wikipedia
+instance Illuminant 'F10 where
+  type Temperature 'F10 = 5000
+  whitePoint = WhitePoint 0.34609 0.35986
+
+-- | @[x=0.38052, y=0.37713]@ - 2° Observer - Wikipedia
+instance Illuminant 'F11 where
+  type Temperature 'F11 = 4000
+  whitePoint = WhitePoint 0.38052 0.37713
+
+-- | @[x=0.43695, y=0.40441]@ - 2° Observer - Wikipedia
+instance Illuminant 'F12 where
+  type Temperature 'F12 = 3000
+  whitePoint = WhitePoint 0.43695 0.40441
+
+
+-- | 2° observer [Standard
+-- Illuminants](https://en.wikipedia.org/wiki/Standard_illuminant#White_point) listed on
+-- Wikipedia. Despite the fact that they have slightly different chromaticity coordinates
+-- than the actual CIE1931 standard papers, these are very commmonly used values. For
+-- better interoperability it is better to use the actual
+-- `Graphics.Color.Illuminant.CIE1931.CIE1931` illuminants.
+--
+-- @since 0.1.1
+data Degree2
+  = A
+  -- ^ Incandescent / Tungsten
+  | B
+  -- ^ Direct sunlight at noon (obsolete)
+  | C
+  -- ^ Average / North sky Daylight (obsolete)
+  | D50
+  -- ^  Horizon Light.
+  | D55
+  -- ^ Mid-morning / Mid-afternoon Daylight
+  | D65
+  -- ^ Noon Daylight
+  | D75
+  -- ^ Overcast dayligh / North sky Daylight
+  | E
+  -- ^ Equal energy
+  | F1
+  -- ^ Daylight Fluorescent
+  | F2
+  -- ^ 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
+  | F3
+  -- ^ White Fluorescent
+  | F4
+  -- ^ Warm White Fluorescent
+  | F5
+  -- ^ Daylight Fluorescent
+  | F6
+  -- ^ Lite White Fluorescent
+  | F7
+  -- ^ Represents a broadband fluorescent lamp, which approximates CIE illuminant `D65`
+  -- (6500° Kelvin, CRI 90).
+  --
+  -- /Note/ - Takes precedence over other F illuminants
+  | F8
+  -- ^ `D50` simulator, Sylvania F40 Design 50 (F40DSGN50)
+  | F9
+  -- ^ Cool White Deluxe Fluorescent
+  | F10
+  -- ^ Philips TL85, Ultralume 50
+  | F11
+  -- ^ 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
+  | F12
+  -- ^ Philips TL83, Ultralume 30
+  deriving (Eq, Show, Read, Enum, Bounded)

Color/src/Graphics/Color/Space.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 -- |
 -- Module      : Graphics.Color.Space
 -- Copyright   : (c) Alexey Kuleshevich 2018-2019
@@ -7,10 +9,35 @@
 -- Portability : non-portable
 --
 module Graphics.Color.Space
-  ( module X
+  ( convertColor
+  , convertColorFloat
+  , 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
+
+
+-- | Convert a color space through `XYZ` intermediary with `Double` precision. Illuminant is
+-- enforced to be the same, but in case that it is a limitation and chromatic adaptation is
+-- needed `Graphics.Color.Adaptation.convertWith` can be used instead.
+--
+-- @since 0.1.1
+convertColor ::
+     forall cs cs' i e. (ColorSpace cs' i e, ColorSpace cs i e)
+  => Color cs' e
+  -> Color cs e
+convertColor = fromColorXYZ . (toColorXYZ :: Color cs' e -> Color (XYZ i) Double)
+{-# INLINE convertColor #-}
+
+-- | Same as `convertColor`, but use 32but `Float` asn an intermediary precision
+--
+-- @since 0.1.1
+convertColorFloat ::
+     forall cs cs' i e. (ColorSpace cs' i e, ColorSpace cs i e)
+  => Color cs' e
+  -> Color cs e
+convertColorFloat = fromColorXYZ . (toColorXYZ :: Color cs' e -> Color (XYZ i) Float)
+{-# INLINE convertColorFloat #-}

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

@@ -0,0 +1,56 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+module Graphics.Color.Illuminant.WikipediaSpec (spec) where
+
+import Data.Proxy
+import Graphics.Color.Space.Common
+import Graphics.Color.Illuminant.Wikipedia
+import qualified Data.Colour.CIE as Colour
+import qualified Data.Colour.CIE.Illuminant as Colour
+
+shouldMatch ::
+     forall i. Illuminant i
+  => (Double, Double, Double)
+  -> WhitePoint i Double
+  -> Spec
+shouldMatch (x, y, _) wp =
+  let (x', y', z') = (xWhitePoint wp, yWhitePoint wp, zWhitePoint wp)
+   in it (showsType (Proxy :: Proxy (WhitePoint i Double)) "") $ do
+        x `shouldBe` x'
+        y `shouldBe` y'
+        epsilonExpect 1e-15 1 (x' + y' + z')
+
+instance Arbitrary Degree2 where
+  arbitrary = arbitraryBoundedEnum
+
+spec :: Spec
+spec =
+  describe "Wikipedia" $ do
+    describe "Match 'colour' package" $ do
+      Colour.chromaCoords Colour.a `shouldMatch` (whitePoint :: WhitePoint 'A Double)
+      Colour.chromaCoords Colour.b `shouldMatch` (whitePoint :: WhitePoint 'B Double)
+      Colour.chromaCoords Colour.c `shouldMatch` (whitePoint :: WhitePoint 'C Double)
+      Colour.chromaCoords Colour.d50 `shouldMatch` (whitePoint :: WhitePoint 'D50 Double)
+      Colour.chromaCoords Colour.d55 `shouldMatch` (whitePoint :: WhitePoint 'D55 Double)
+      Colour.chromaCoords Colour.d65 `shouldMatch` (whitePoint :: WhitePoint 'D65 Double)
+      Colour.chromaCoords Colour.d75 `shouldMatch` (whitePoint :: WhitePoint 'D75 Double)
+      Colour.chromaCoords Colour.e `shouldMatch` (whitePoint :: WhitePoint 'E Double)
+      Colour.chromaCoords Colour.f1 `shouldMatch` (whitePoint :: WhitePoint 'F1 Double)
+      Colour.chromaCoords Colour.f2 `shouldMatch` (whitePoint :: WhitePoint 'F2 Double)
+      Colour.chromaCoords Colour.f3 `shouldMatch` (whitePoint :: WhitePoint 'F3 Double)
+      Colour.chromaCoords Colour.f4 `shouldMatch` (whitePoint :: WhitePoint 'F4 Double)
+      Colour.chromaCoords Colour.f5 `shouldMatch` (whitePoint :: WhitePoint 'F5 Double)
+      Colour.chromaCoords Colour.f6 `shouldMatch` (whitePoint :: WhitePoint 'F6 Double)
+      Colour.chromaCoords Colour.f7 `shouldMatch` (whitePoint :: WhitePoint 'F7 Double)
+      Colour.chromaCoords Colour.f8 `shouldMatch` (whitePoint :: WhitePoint 'F8 Double)
+      Colour.chromaCoords Colour.f9 `shouldMatch` (whitePoint :: WhitePoint 'F9 Double)
+      Colour.chromaCoords Colour.f10 `shouldMatch` (whitePoint :: WhitePoint 'F10 Double)
+      Colour.chromaCoords Colour.f11 `shouldMatch` (whitePoint :: WhitePoint 'F11 Double)
+      Colour.chromaCoords Colour.f12 `shouldMatch` (whitePoint :: WhitePoint 'F12 Double)
+    describe "Derived Classes" $ do
+      it "Bounded" $ [minBound .. maxBound] `shouldBe` [A .. F12]
+      prop "Enum" $ \ (i :: Degree2) -> toEnum (fromEnum i) === i
+      prop "Read . Show" $ \ (i :: Degree2) -> read (show i) === i
+      prop "Read . Show" $ \ is -> read (show is) === (is :: [Degree2])

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

@@ -36,6 +36,7 @@ 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)
 
@@ -65,7 +66,9 @@ 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)
+    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)