Color 0.4.0 → 0.4.1

raw patch · 11 files changed

+404/−23 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• Color.cabal +8/−4
• src/Graphics/Color/Algebra/Binary.hs +3/−0
• src/Graphics/Color/Algebra/Elevator.hs +34/−5
• src/Graphics/Color/Space/OKLAB.hs +177/−0
• src/Graphics/Color/Space/OKLAB/LCH.hs +107/−0
• tests/Graphics/Color/Algebra/ElevatorSpec.hs +12/−4
• tests/Graphics/Color/Model/Common.hs +1/−1
• tests/Graphics/Color/Space/Common.hs +9/−9
• tests/Graphics/Color/Space/OKLAB/LAB/LCHSpec.hs +30/−0
• tests/Graphics/Color/Space/OKLAB/LABSpec.hs +18/−0

@@ -1,5 +1,10 @@ # Changelog for Color +## 0.4.1++* Addition of `OKLAB` and `OKLCH` color spaces. From the [CSS 4 Color+  Specification](https://drafts.csswg.org/css-color-4/#:~:text=XYZ_to_OKLab)+ ## 0.4.0  * Addition of `DIN99` color space.

@@ -1,5 +1,5 @@ name:                Color-version:             0.4.0+version:             0.4.1 synopsis:            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@@ -22,10 +22,10 @@                     , GHC == 9.0.2                     , GHC == 9.2.8                     , GHC == 9.4.8-                    , GHC == 9.6.6+                    , GHC == 9.6.7                     , GHC == 9.8.4-                    , GHC == 9.10.1-                    , GHC == 9.12.1+                    , GHC == 9.10.3+                    , GHC == 9.12.2  library   hs-source-dirs:      src@@ -47,6 +47,8 @@                      , Graphics.Color.Space.CIE1931.RGB                      , Graphics.Color.Space.CIE1931.XYZ                      , Graphics.Color.Space.CIE1976.LAB+                     , Graphics.Color.Space.OKLAB+                     , Graphics.Color.Space.OKLAB.LCH                      , Graphics.Color.Space.CIE1976.LAB.LCH                      , Graphics.Color.Space.CIE1976.LUV                      , Graphics.Color.Space.CIE1976.LUV.LCH@@ -129,6 +131,8 @@                     , Graphics.Color.Space.CIE1976.LAB.LCHSpec                     , Graphics.Color.Space.CIE1976.LUVSpec                     , Graphics.Color.Space.CIE1976.LUV.LCHSpec+                    , Graphics.Color.Space.OKLAB.LABSpec+                    , Graphics.Color.Space.OKLAB.LAB.LCHSpec                     , Graphics.Color.Space.RGB.AdobeRGBSpec                     , Graphics.Color.Space.RGB.SRGBSpec                     , Graphics.Color.Space.RGB.Derived.AdobeRGBSpec

@@ -134,6 +134,9 @@   toShowS _       = ('1':)   toWord8 = coerce   {-# INLINE toWord8 #-}+  fromWord8 0 = zero+  fromWord8 _ = one+  {-# INLINE fromWord8 #-}   toWord16 (Bit 0) = 0   toWord16 _       = maxBound   {-# INLINE toWord16 #-}

@@ -49,6 +49,9 @@   -- | Values are scaled to @[0, 255]@ range.   toWord8 :: e -> Word8 +  -- | Values are scaled from @[0, 255]@ range to @[minValue, maxValue]@.+  fromWord8 :: Word8 -> e+   -- | Values are scaled to @[0, 65535]@ range.   toWord16 :: e -> Word16 @@ -158,6 +161,8 @@   fieldFormat _ = defFieldFormat {fmtWidth = Just 3, fmtChar = 'd'}   toWord8 = id   {-# INLINE toWord8 #-}+  fromWord8 = id+  {-# INLINE fromWord8 #-}   toWord16 = raiseUp   {-# INLINE toWord16 #-}   toWord32 = raiseUp@@ -185,6 +190,8 @@   fieldFormat _ = defFieldFormat { fmtWidth = Just 5, fmtChar = 'd'}   toWord8 = dropDown   {-# INLINE toWord8 #-}+  fromWord8 = raiseUp+  {-# INLINE fromWord8 #-}   toWord16 = id   {-# INLINE toWord16 #-}   toWord32 = raiseUp@@ -212,6 +219,8 @@   fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'}   toWord8 = dropDown   {-# INLINE toWord8 #-}+  fromWord8 = raiseUp+  {-# INLINE fromWord8 #-}   toWord16 = dropDown   {-# INLINE toWord16 #-}   toWord32 = id@@ -239,6 +248,8 @@   fieldFormat _ = defFieldFormat { fmtWidth = Just 20, fmtChar = 'd'}   toWord8 = dropDown   {-# INLINE toWord8 #-}+  fromWord8 = raiseUp+  {-# INLINE fromWord8 #-}   toWord16 = dropDown   {-# INLINE toWord16 #-}   toWord32 = dropDown@@ -277,6 +288,8 @@ #endif   toWord8 = dropDown   {-# INLINE toWord8 #-}+  fromWord8 = raiseUp+  {-# INLINE fromWord8 #-}   toWord16 = dropDown   {-# INLINE toWord16 #-}   toWord32 = dropDown@@ -297,8 +310,10 @@   maxValue = maxBound   minValue = 0   fieldFormat _ = defFieldFormat { fmtWidth = Just 3, fmtChar = 'd'}-  toWord8 = fromIntegral . max 0+  toWord8 = raiseUp . max 0   {-# INLINE toWord8 #-}+  fromWord8 = dropDown+  {-# INLINE fromWord8 #-}   toWord16 = raiseUp . max 0   {-# INLINE toWord16 #-}   toWord32 = raiseUp . max 0@@ -322,7 +337,9 @@   fieldFormat _ = defFieldFormat { fmtWidth = Just 5, fmtChar = 'd'}   toWord8 = dropDown . max 0   {-# INLINE toWord8 #-}-  toWord16 = fromIntegral . max 0+  fromWord8 = raiseUp+  {-# INLINE fromWord8 #-}+  toWord16 = raiseUp . max 0   {-# INLINE toWord16 #-}   toWord32 = raiseUp . max 0   {-# INLINE toWord32 #-}@@ -345,9 +362,11 @@   fieldFormat _ = defFieldFormat { fmtWidth = Just 10, fmtChar = 'd'}   toWord8 = dropDown . max 0   {-# INLINE toWord8 #-}+  fromWord8 = raiseUp+  {-# INLINE fromWord8 #-}   toWord16 = dropDown . max 0   {-# INLINE toWord16 #-}-  toWord32 = fromIntegral . max 0+  toWord32 = raiseUp . max 0   {-# INLINE toWord32 #-}   toWord64 = raiseUp . max 0   {-# INLINE toWord64 #-}@@ -368,11 +387,13 @@   fieldFormat _ = defFieldFormat { fmtWidth = Just 19, fmtChar = 'd'}   toWord8 = dropDown . max 0   {-# INLINE toWord8 #-}+  fromWord8 = raiseUp+  {-# INLINE fromWord8 #-}   toWord16 = dropDown . max 0   {-# INLINE toWord16 #-}   toWord32 = dropDown . max 0   {-# INLINE toWord32 #-}-  toWord64 = fromIntegral . max 0+  toWord64 = raiseUp . max 0   {-# INLINE toWord64 #-}   toFloat = squashTo1 . max 0   {-# INLINE toFloat #-}@@ -394,11 +415,13 @@   {-# INLINE toWord64 #-} #else   fieldFormat _ = defFieldFormat { fmtWidth = Just 19, fmtChar = 'd'}-  toWord64 = fromIntegral . max 0+  toWord64 = raiseUp . max 0   {-# INLINE toWord64 #-} #endif   toWord8 = dropDown . max 0   {-# INLINE toWord8 #-}+  fromWord8 = raiseUp+  {-# INLINE fromWord8 #-}   toWord16 = dropDown . max 0   {-# INLINE toWord16 #-}   toWord32 = dropDown . max 0@@ -420,6 +443,8 @@   fieldFormat _ = defFieldFormat { fmtWidth = Just 11, fmtPrecision = Just 8, fmtChar = 'f'}   toWord8 = stretch   {-# INLINE toWord8 #-}+  fromWord8 = squashTo1+  {-# INLINE fromWord8 #-}   toWord16 = stretch   {-# INLINE toWord16 #-}   toWord32 = float2Word32@@ -447,6 +472,8 @@   fieldFormat _ = defFieldFormat { fmtWidth = Just 19, fmtPrecision = Just 16, fmtChar = 'f' }   toWord8 = stretch   {-# INLINE toWord8 #-}+  fromWord8 = squashTo1+  {-# INLINE fromWord8 #-}   toWord16 = stretch   {-# INLINE toWord16 #-}   toWord32 = stretch@@ -484,6 +511,8 @@   toShowS (r :+ i) = toShowS r . formatArg i ((fieldFormat i) {fmtSign = Just SignPlus}) . ('i' :)   toWord8 = toWord8 . realPart   {-# INLINE toWord8 #-}+  fromWord8 = (:+ 0) . fromWord8+  {-# INLINE fromWord8 #-}   toWord16 = toWord16 . realPart   {-# INLINE toWord16 #-}   toWord32 = toWord32 . realPart

@@ -0,0 +1,177 @@+{-# LANGUAGE BangPatterns #-}+{-# 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.OKLAB+-- Copyright   : (c) Alexey Kuleshevich 2018-2020+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Graphics.Color.Space.OKLAB+  ( -- * Constructors for an CIE L*a*b* color space.+    pattern OKLAB+  , pattern ColorOKLAB+  , pattern ColorOKLABA+  , OKLAB+  ) where++import Data.List.NonEmpty+import Foreign.Storable+import Graphics.Color.Model.Internal+import Graphics.Color.Space.Internal+import Graphics.Color.Illuminant.ITU.Rec601 (D65)++--------------+--- OKLAB ---+--------------++-- | [OK L*a*b*](https://bottosson.github.io/posts/oklab/) color space+--+-- Values for matrices used in conversion to and from @CIEXYZ@ where taken from+-- [W3 CSS specification](https://www.w3.org/TR/css-color-4/#color-conversion-code) +-- instead of the original blogpost about the OKLab color space.+data OKLAB++-- | Color in OK L*a*b* color space+newtype instance Color OKLAB e = OKLAB (V3 e)+++pattern ColorOKLAB :: e -> e -> e -> Color OKLAB e+pattern ColorOKLAB l' a' b' = OKLAB (V3 l' a' b')+{-# COMPLETE ColorOKLAB #-}++-- | Constructor for @OKLAB@ with alpha channel.+pattern ColorOKLABA :: e -> e -> e -> e -> Color (Alpha OKLAB) e+pattern ColorOKLABA l' a' b' a = Alpha (OKLAB (V3 l' a' b')) a+{-# COMPLETE ColorOKLABA #-}++-- | `OKLAB` color space+deriving instance Eq e => Eq (Color OKLAB e)++-- | `OKLAB` color space+deriving instance Ord e => Ord (Color OKLAB e)++-- | `OKLAB` color space+deriving instance Functor (Color OKLAB)++-- | `OKLAB` color space+deriving instance Applicative (Color OKLAB)++-- | `OKLAB` color space+deriving instance Foldable (Color OKLAB)++-- | `OKLAB` color space+deriving instance Traversable (Color OKLAB)++-- | `OKLAB` color space+deriving instance Storable e => Storable (Color OKLAB e)++-- | `OKLAB` color space+instance (Elevator e) => Show (Color OKLAB e) where+  showsPrec _ = showsColorModel++-- | `OKLAB` color space+instance (Elevator e) => ColorModel OKLAB e where+  type Components OKLAB e = (e, e, e)+  type ChannelCount OKLAB = 3+  channelCount _ = 3+  {-# INLINE channelCount #-}+  channelNames _ = "L*" :| ["a*", "b*"]+  channelColors _ = V3 0x80 0x80 0x80 :| -- gray+                  [ V3 0xb5 0x00 0x5e    -- dark magenta+                  , V3 0x00 0x00 0x8b    -- dark gold+                  ]+  toComponents (ColorOKLAB l' a' b') = (l', a', b')+  {-# INLINE toComponents #-}+  fromComponents (l', a', b') = ColorOKLAB l' a' b'+  {-# INLINE fromComponents #-}++instance (Elevator e, RealFloat e) => ColorSpace OKLAB D65 e where+  type BaseModel OKLAB = OKLAB+  type BaseSpace OKLAB = OKLAB+  toBaseSpace = id+  {-# INLINE toBaseSpace #-}+  fromBaseSpace = id+  {-# INLINE fromBaseSpace #-}+  luminance c = Y $ lab2luminance c+  {-# INLINE luminance #-}+  toColorXYZ = lab2xyz+  {-# INLINE toColorXYZ #-}+  fromColorXYZ = xyz2lab+  {-# INLINE fromColorXYZ #-}+  grayscale (ColorOKLAB l' _ _) = X l'+  {-# INLINE grayscale #-}+  replaceGrayscale (ColorOKLAB _ a' b') (X l') = ColorOKLAB l' a' b'+  {-# INLINE replaceGrayscale #-}++lab2luminance :: forall a e. (Elevator e, Elevator a, RealFloat e, RealFloat a)+  => Color OKLAB e+  -> a+lab2luminance (ColorOKLAB ll a b) = toRealFloat y+  where+    !l' = ll + 0.3963377773761749 * a + 0.2158037573099136 * b+    !m' = ll - 0.1055613458156586 * a - 0.0638541728258133 * b+    !s' = ll - 0.0894841775298119 * a - 1.2914855480194092 * b+    !l = l' ^ (3 :: Int)+    !m = m' ^ (3 :: Int)+    !s = s' ^ (3 :: Int)+    !y = (-0.0405757452148008) * l + 1.1122868032803170 * m - 0.0717110580655164 * s+{-# INLINE lab2luminance #-}++lab2xyz ::+     forall a e. (Elevator e, Elevator a, RealFloat e, RealFloat a)+  => Color OKLAB e+  -> Color (XYZ D65) a+lab2xyz (ColorOKLAB ll a b) = ColorXYZ rfX rfY rfZ+  where+    !l' = ll + 0.3963377773761749 * a + 0.2158037573099136 * b+    !m' = ll - 0.1055613458156586 * a - 0.0638541728258133 * b+    !s' = ll - 0.0894841775298119 * a - 1.2914855480194092 * b+    !l = l' ^ (3 :: Int)+    !m = m' ^ (3 :: Int)+    !s = s' ^ (3 :: Int)+    !x =  1.2268798758459243   * l - 0.5578149944602171 * m + 0.2813910456659647 * s+    !y = (-0.0405757452148008) * l + 1.1122868032803170 * m - 0.0717110580655164 * s+    !z = (-0.0763729366746601) * l - 0.4214933324022432 * m + 1.5869240198367816 * s+    !rfX = toRealFloat x+    !rfY = toRealFloat y+    !rfZ = toRealFloat z+{-# INLINE lab2xyz #-}++signedCubeRoot :: RealFloat e => e -> e+signedCubeRoot x =+  if x < 0+    then -((-x) ** (1 / 3))+    else x ** (1 / 3)+{-# INLINE signedCubeRoot #-}++xyz2lab ::+     forall a e. (Elevator a, Elevator e, RealFloat a, RealFloat e)+  => Color (XYZ D65) a+  -> Color OKLAB e+xyz2lab (ColorXYZ x y z) = ColorOKLAB rfL rfA rfB+  where+    !l = 0.8190224379967030 * x + 0.3619062600528904 * y - 0.1288737815209879 * z+    !m = 0.0329836539323885 * x + 0.9292868615863434 * y + 0.0361446663506424 * z+    !s = 0.0481771893596242 * x + 0.2642395317527308 * y + 0.6335478284694309 * z+    !l' = signedCubeRoot l+    !m' = signedCubeRoot m+    !s' = signedCubeRoot s+    !ll = 0.2104542683093140 * l' + 0.7936177747023054 * m' - 0.0040720430116193 * s'+    !a  = 1.9779985324311684 * l' - 2.4285922420485799 * m' + 0.4505937096174110 * s'+    !b  = 0.0259040424655478 * l' + 0.7827717124575296 * m' - 0.8086757549230774 * s'+    !rfL = toRealFloat ll+    !rfA = toRealFloat a+    !rfB = toRealFloat b+{-# INLINE xyz2lab #-}

@@ -0,0 +1,107 @@+{-# 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.OKLAB.LCH++module Graphics.Color.Space.OKLAB.LCH+  ( pattern ColorOKLCH+  , pattern ColorOKLCHA+  , OKLCH+  , Color(OKLCH)+  ) where++import Data.Coerce+import Data.List.NonEmpty+import Data.Proxy+import Foreign.Storable+import qualified Graphics.Color.Model.LCH as CM+import Graphics.Color.Space.OKLAB+import Graphics.Color.Model.Internal+import Graphics.Color.Space.Internal+import Graphics.Color.Illuminant.ITU.Rec601 (D65)++-- | [OK L*C*H*](https://bottosson.github.io/posts/oklab/) color space+--   an LCH representation for the L*a*b* color space+data OKLCH++-- | Color in OKLCH color space+newtype instance Color OKLCH e = OKLCH (Color CM.LCH e)++-- | `OKLCH` color space+deriving instance Eq e => Eq (Color OKLCH e)++-- | `OKLCH` color space+deriving instance Ord e => Ord (Color OKLCH e)++-- | `OKLCH` color space+deriving instance Functor (Color OKLCH)++-- | `OKLCH` color space+deriving instance Applicative (Color OKLCH)++-- | `OKLCH` color space+deriving instance Foldable (Color OKLCH)++-- | `OKLCH` color space+deriving instance Traversable (Color OKLCH)++-- | `OKLCH` color space+deriving instance Storable e => Storable (Color OKLCH e)++-- | `OKLCH` color space+instance (Elevator e) => Show (Color OKLCH e) where+  showsPrec _ = showsColorModel++-- | Constructor for a OKL*a*b* color space in a cylindrical L*C*h parameterization+pattern ColorOKLCH :: e -> e -> e -> Color OKLCH e+pattern ColorOKLCH l c h = OKLCH (CM.ColorLCH l c h)+{-# COMPLETE ColorOKLCH #-}++-- | Constructor for a @OKLCH@ with alpha+pattern ColorOKLCHA :: e -> e -> e -> e -> Color (Alpha OKLCH) e+pattern ColorOKLCHA l c h a = Alpha (OKLCH (CM.ColorLCH l c h)) a+{-# COMPLETE ColorOKLCHA #-}++-- | `OKLCH` color space+instance (Elevator e, ColorModel OKLAB e) => ColorModel OKLCH e where+  type Components OKLCH e = (e, e, e)+  type ChannelCount OKLCH = 3+  channelCount _ = 3+  {-# INLINE channelCount #-}+  channelNames _ = "L" :| ["Cab", "Hab"]+  channelColors _ = V3 0x80 0x80 0x80 :|+                  [ V3 0xff 0x31 0x8e+                  , V3 0x66 0x66 0xff+                  ]+  toComponents (OKLCH lch) = toComponents lch+  {-# INLINE toComponents #-}+  fromComponents = OKLCH . fromComponents+  {-# INLINE fromComponents #-}+  showsColorModelName _ =+    ("LCH-"++) . showsColorModelName (Proxy :: Proxy (Color OKLAB e))++instance (Elevator e, ColorSpace OKLAB D65 e) => ColorSpace OKLCH D65 e where+  type BaseModel OKLCH = CM.LCH+  type BaseSpace OKLCH = OKLAB+  toBaseSpace (OKLCH lch) = fmap fromDouble . fromComponents . CM.lch2lxy . fmap toDouble $ lch+  {-# INLINE toBaseSpace #-}+  fromBaseSpace = OKLCH . fmap fromDouble . CM.lxy2lch . toComponents . fmap toDouble+  {-# INLINE fromBaseSpace #-}+  luminance = luminance . toBaseSpace+  {-# INLINE luminance #-}+  grayscale (coerce -> V3 l _ _) = X l+  {-# INLINE grayscale #-}+  replaceGrayscale (coerce -> V3 _ c h) (X l) = coerce (V3 l c h)+  {-# INLINE replaceGrayscale #-}

@@ -37,6 +37,7 @@     describe "Word8" $ do       specNegativeBecomesZero (Proxy :: Proxy Word8)       eprop "toWord8" $ \(e :: Word8) -> e === toWord8 e+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Word8)       eprop "toWord8 . toWord16" $ \(e :: Word8) -> e === toWord8 (toWord16 e)       eprop "toWord8 . toWord32" $ \(e :: Word8) -> e === toWord8 (toWord32 e)       eprop "toWord8 . toWord64" $ \(e :: Word8) -> e === toWord8 (toWord64 e)@@ -57,6 +58,7 @@       eprop "read . toShowS" $ \(e :: Word8) -> e === read (toShowS e "")     describe "Word16" $ do       specNegativeBecomesZero (Proxy :: Proxy Word16)+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Word16)       eprop "toWord16" $ \(e :: Word16) -> e === toWord16 e       eprop "toWord16 . toWord32" $ \(e :: Word16) -> e === toWord16 (toWord32 e)       eprop "toWord16 . toWord64" $ \(e :: Word16) -> e === toWord16 (toWord64 e)@@ -76,6 +78,7 @@       eprop "read . toShowS" $ \(e :: Word16) -> e === read (toShowS e "")     describe "Word32" $ do       specNegativeBecomesZero (Proxy :: Proxy Word32)+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Word32)       eprop "toWord32" $ \(e :: Word32) -> e === toWord32 e       eprop "toWord32 . toWord64" $ \(e :: Word32) -> e === toWord32 (toWord64 e)       prop "toWord32 . toFloat" $@@ -97,6 +100,7 @@       eprop "read . toShowS" $ \(e :: Word32) -> e === read (toShowS e "")     describe "Word64" $ do       specNegativeBecomesZero (Proxy :: Proxy Word64)+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Word64)       eprop "toWord64" $ \(e :: Word64) -> e === toWord64 e       prop "toWord64 . toFloat" $         forAll (choose (0, maxFloatI)) $ \(e :: Word64) -> e === toWord64 (toFloat e)@@ -123,6 +127,7 @@       eprop "read . toShowS" $ \(e :: Word64) -> e === read (toShowS e "")     describe "Word" $ do       specNegativeBecomesZero (Proxy :: Proxy Word)+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Word)       eprop "toWord64" $ \(e :: Word) -> fromIntegral e === toWord64 e       prop "toWord64 . toFloat" $         forAll (choose (0, maxFloatI)) $ \(e :: Word) -> fromIntegral e === toWord64 (toFloat e)@@ -149,6 +154,7 @@           shouldBeApproxIntegral 1 e (fromRealFloat (toDouble e))       eprop "read . toShowS" $ \(e :: Word) -> e === read (toShowS e "")     describe "Float" $ do+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Float)       eprop "fromRealFloat . toFloat" $ \(e :: Float) -> e === fromRealFloat (toFloat e)       eprop "fromRealFloat . toDouble" $ \(e :: Float) -> e === fromRealFloat (toDouble e)       eprop "fromRealFloat . toRealFloat :: Float" $ \(e :: Float) ->@@ -160,6 +166,7 @@       --eprop "read . toShowS" $ \(e :: Float) -> e === read (toShowS e "")       it "toWord32 (maxBound edge case)" $ toWord32 (1 :: Float) `shouldBe` maxBound     describe "Double" $ do+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Double)       eprop "fromRealFloat . toDouble" $ \(e :: Double) -> e === fromRealFloat (toDouble e)       eprop "fromRealFloat . toRealFloat :: Double" $ \(e :: Double) ->         e === fromRealFloat (toRealFloat e :: Double)@@ -170,7 +177,7 @@         pos = fromIntegral . max 0     describe "Int8" $ do       specNegativeBecomesPositive (Proxy :: Proxy Int8)-      eprop "toWord8" $ \(e :: Int8) -> pos e === toWord8 e+      eprop "fromWord8 . toWord8" $ \(e :: Int8) -> e === fromWord8 (toWord8 e)       eprop "fromRealFloat . toFloat :: Float" $ \(e :: Int8) ->         (pos e :: Int8) === fromRealFloat (toFloat e :: Float)       eprop "fromRealFloat . toRealFloat :: Float" $ \(e :: Int8) ->@@ -183,7 +190,7 @@       eprop "read . toShowS" $ \(e :: Int8) -> e === read (toShowS e "")     describe "Int16" $ do       specNegativeBecomesPositive (Proxy :: Proxy Int16)-      eprop "toWord16" $ \(e :: Int16) -> pos e === toWord16 e+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Int16)       eprop "fromRealFloat . toFloat :: Float" $ \(e :: Int16) ->         (pos e :: Int16) === fromRealFloat (toFloat e :: Float)       eprop "fromRealFloat . toRealFloat :: Float" $ \(e :: Int16) ->@@ -196,7 +203,7 @@       eprop "read . toShowS" $ \(e :: Int16) -> e === read (toShowS e "")     describe "Int32" $ do       specNegativeBecomesPositive (Proxy :: Proxy Int32)-      eprop "toWord32" $ \(e :: Int32) -> pos e === toWord32 e+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Int32)       prop "fromRealFloat . toFloat :: Float" $         forAll (choose (0, maxFloatI)) $ \(e :: Int32) ->           (pos e :: Int32) === fromRealFloat (toFloat e)@@ -209,7 +216,7 @@       eprop "read . toShowS" $ \(e :: Int32) -> e === read (toShowS e "")     describe "Int64" $ do       specNegativeBecomesPositive (Proxy :: Proxy Int64)-      eprop "toWord64" $ \(e :: Int64) -> pos e === toWord64 e+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Int64)       prop "fromRealFloat . toRealFloat :: Float" $         forAll (choose (0, maxFloatI)) $ \(e :: Int64) ->           (pos e :: Int64) === fromRealFloat (toRealFloat e :: Float)@@ -222,6 +229,7 @@       eprop "read . toShowS" $ \(e :: Int64) -> e === read (toShowS e "")     describe "Int" $ do       specNegativeBecomesPositive (Proxy :: Proxy Int)+      eprop "toWord8 . fromWord8" $ \(e :: Word8) -> e === toWord8 (fromWord8 e :: Int)       prop "fromRealFloat . toRealFloat :: Float" $         forAll (choose (0, maxFloatI)) $ \(e :: Int) ->           (pos e :: Int) === fromRealFloat (toRealFloat e :: Float)

@@ -205,7 +205,7 @@  -- | Same as `epsilonEqColorTol` but with indexed counterexample. epsilonEqColorTolIx ::-     (ColorModel cs e, RealFloat e) => e -> Int -> Color cs e -> Color cs e -> Property+     (ColorModel cs e, RealFloat e, HasCallStack) => e -> Int -> Color cs e -> Color cs e -> Property epsilonEqColorTolIx tol ix expected actual =   counterexample ("Index: " ++ show ix) $ epsilonEqColorTol tol expected actual 

@@ -31,7 +31,7 @@   prop_toFromColorXYZ ::-     forall cs e i. (ColorSpace cs i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, RealFloat e, HasCallStack)   => Color cs e   -> Property prop_toFromColorXYZ c = c `epsilonEqColor` fromColorXYZ (toColorXYZ c :: Color (XYZ i) Double)@@ -39,26 +39,26 @@  -- For RGB standards, that have matrices rounded to 4 digits after the decimal point prop_toFromLenientColorXYZ ::-     forall cs e i. (ColorSpace cs i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, RealFloat e, HasCallStack)   => e   -> Color cs e   -> Property prop_toFromLenientColorXYZ epsilon c =   epsilonEqColorTol epsilon c (fromColorXYZ (toColorXYZ c :: Color (XYZ i) Double)) -prop_LuminanceColorXYZ :: forall cs e i . ColorSpace cs i e => Color cs e -> Property+prop_LuminanceColorXYZ :: forall cs e i . (ColorSpace cs i e, HasCallStack) => 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 e i. (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, HasCallStack)   => Color cs e   -> Property prop_toFromBaseSpace c = c `epsilonEqColor` fromBaseSpace (toBaseSpace c)  prop_toFromBaseSpaceLenient ::-     forall cs e i. (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, HasCallStack)   => e   -> Color cs e   -> Property@@ -72,14 +72,14 @@ prop_toFromBaseModel c = c === fromBaseModel (toBaseModel c)  prop_toApplyGrayscale ::-     forall cs e i. (ColorSpace cs i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, RealFloat e, HasCallStack)   => e   -> Color cs e   -> Property prop_toApplyGrayscale epsilon c = epsilonEqColorTol epsilon c $ applyGrayscale c id  prop_toReplaceGrayscale ::-     forall cs e i. (ColorSpace cs i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, RealFloat e, HasCallStack)   => e   -> Color cs e   -> Property@@ -87,7 +87,7 @@   epsilonEqColorTol epsilon c (replaceGrayscale c (grayscale c))  prop_toApplyGrayscaleAsReplace ::-     forall cs e i. (ColorSpace cs i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, RealFloat e, HasCallStack)   => e   -> Color cs e   -> Fun (Color X e) (Color X e)@@ -100,7 +100,7 @@   prop_toReplaceGrayscaleAsApply ::-     forall cs e i. (ColorSpace cs i e, RealFloat e)+     forall cs e i. (ColorSpace cs i e, RealFloat e, HasCallStack)   => e   -> Color cs e   -> Color X e

@@ -0,0 +1,30 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Graphics.Color.Space.OKLAB.LAB.LCHSpec (spec) where++import Data.Coerce ( coerce )+import Graphics.Color.Model ( lxy2lch, lch2lxy )+import Graphics.Color.Space.Common+import Graphics.Color.Space.OKLAB.LABSpec ()+import Graphics.Color.Space.OKLAB.LCH+import Graphics.Color.Space.OKLAB++instance (Elevator e, Random e) => Arbitrary (Color OKLCH e) where+  arbitrary = ColorOKLCH <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator++spec :: Spec+spec =+  describe "OKLCH" $ do+    colorModelSpec @OKLCH @Word "LCH-OKLAB"+    colorSpaceLenientSpec @OKLCH @Double 1e-9+    prop "lab2lch . lch2lab" $ \(lab :: Color OKLAB Double) ->+      lab `epsilonEqColor` lch2lab (lab2lch lab)+    prop "lch2lab . lab2lch" $ \(lch :: Color OKLCH Double) ->+      lch `epsilonEqColor` lab2lch (lch2lab lch)++lab2lch :: Color OKLAB Double -> Color OKLCH Double+lab2lch = coerce . lxy2lch . toComponents++lch2lab :: Color OKLCH Double -> Color OKLAB Double+lch2lab = fromComponents . lch2lxy . coerce

@@ -0,0 +1,18 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Graphics.Color.Space.OKLAB.LABSpec (spec) where++import Graphics.Color.Space.Common+import Graphics.Color.Space.RGB.Derived.SRGBSpec ()+import Graphics.Color.Space.OKLAB++instance (Elevator e, Random e) => Arbitrary (Color OKLAB e) where+  arbitrary = ColorOKLAB <$> arbitraryElevator <*> arbitraryElevator <*> arbitraryElevator++spec :: Spec+spec = describe "OKLAB" $ do+  colorModelSpec @OKLAB @Word "OKLAB"+  colorSpaceLenientSpec @OKLAB @Double 1e-9