Apply luma

Color/CHANGELOG.md

@@ -1,5 +1,14 @@
 # Changelog for Color
 
+## 0.4.0
+
+* Scale `L*a*b*` color space to `[0, 1]` range from the more common `[0, 100]` for
+ consistency.
+* Addition of: `toGrayscale`, `applyGrayscale` and `replaceGrayscale`.
+* Addition of: `ChannelCount`, `channelCount`, `channelNames` and `channelColors`
+
+* Remove `RealFloat` constraint from `ColorSpace` for `Y'`
+
 ## 0.3.3
 
 Addition of `SVG` colors

Color/Color.cabal

@@ -1,5 +1,5 @@
 name: Color
-version: 0.3.3
+version: 0.4.0
 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
@@ -193,6 +193,19 @@ benchmark conversion
  , random
  default-language: Haskell2010
 
+benchmark ycbcr
+ type: exitcode-stdio-1.0
+ hs-source-dirs: bench
+ main-is: YCbCr.hs
+ ghc-options: -Wall
+ -threaded
+ -O2
+ build-depends: base
+ , criterion
+ , Color
+ , deepseq
+ default-language: Haskell2010
+
 source-repository head
  type: git
  location: https://github.com/lehins/Color

Color/bench/YCbCr.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Main where
+
+import Criterion.Main
+import Control.DeepSeq
+import qualified Graphics.Color.Model as CM
+import Graphics.Color.Space
+import Graphics.Color.Space.RGB.ITU.Rec601
+import Graphics.Color.Space.RGB.ITU.Rec709
+import Data.Coerce
+
+main :: IO ()
+main = do
+ defaultMain
+ [ bgroup
+ "toYCbCr"
+ [ toYCbCrBench (CM.ColorRGB 0.1 0.2 0.3 :: Color CM.RGB Float) "Float"
+ , toYCbCrBench (CM.ColorRGB 0.1 0.2 0.3 :: Color CM.RGB Double) "Double"
+ ]
+ , bgroup
+ "fromYCbCr"
+ [ fromYCbCrBench (CM.ColorYCbCr 0.1 0.2 0.3 :: Color CM.YCbCr Float) "Float"
+ , fromYCbCrBench (CM.ColorYCbCr 0.1 0.2 0.3 :: Color CM.YCbCr Double) "Double"
+ ]
+ ]
+
+
+toYCbCrBench ::
+ forall e. (Elevator e, NFData e)
+ => Color CM.RGB e
+ -> String
+ -> Benchmark
+toYCbCrBench rgb tyName =
+ bgroup
+ tyName
+ [ bgroup
+ "Standard"
+ [ bench "SRGB" $
+ nf (fromBaseSpace :: Color (SRGB 'NonLinear) e -> Color (Y'CbCr SRGB) e) (mkColorRGB rgb)
+ , bench "Rec601" $
+ nf
+ (fromBaseSpace :: Color (BT601_625 'NonLinear) e -> Color (Y'CbCr BT601_625) e)
+ (mkColorRGB rgb)
+ , bench "Rec709" $
+ nf (fromBaseSpace :: Color (BT709 'NonLinear) e -> Color (Y'CbCr BT709) e) (mkColorRGB rgb)
+ ]
+ ]
+
+fromYCbCrBench ::
+ forall e. (Elevator e, NFData e)
+ => Color CM.YCbCr e
+ -> String
+ -> Benchmark
+fromYCbCrBench ycbcr tyName =
+ bgroup
+ tyName
+ [ bgroup
+ "Standard"
+ [ bench "SRGB" $
+ nf (toBaseSpace :: Color (Y'CbCr SRGB) e -> Color (SRGB 'NonLinear) e) (coerce ycbcr)
+ , bench "Rec601" $
+ nf
+ (toBaseSpace :: Color (Y'CbCr BT601_625) e -> Color (BT601_625 'NonLinear) e)
+ (coerce ycbcr)
+ , bench "Rec709" $
+ nf (toBaseSpace :: Color (Y'CbCr BT709) e -> Color (BT709 'NonLinear) e) (coerce ycbcr)
+ ]
+ ]

Color/src/Graphics/Color/Algebra/Binary.hs

@@ -31,7 +31,7 @@ import qualified Data.Vector.Unboxed as U
 import Foreign.Storable
 import Graphics.Color.Algebra.Elevator
 import Prelude hiding (map)
-
+import Data.Coerce
 
 -- | 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
@@ -43,35 +43,32 @@ instance Show Bit where
  show (Bit 0) = "0"
  show _ = "1"
 
+cf :: (Word8 -> Word8) -> Bit -> Bit
+cf = coerce
+
+cf2 :: (Word8 -> Word8 -> Word8) -> Bit -> Bit -> Bit
+cf2 = coerce
 
 instance Bits Bit where
- (Bit 0) .&. _ = Bit 0
- (Bit 1) .&. (Bit 1) = Bit 1
- _ .&. (Bit 0) = Bit 0
- _ .&. _ = Bit 1
+ (.&.) = cf2 (.&.)
  {-# INLINE (.&.) #-}
- (Bit 1) .|. _ = Bit 1
- (Bit 0) .|. (Bit 0) = Bit 0
- _ .|. _ = Bit 1
+ (.|.) = cf2 (.|.)
  {-# INLINE (.|.) #-}
- (Bit 0) `xor` (Bit 0) = Bit 0
- (Bit 1) `xor` (Bit 1) = Bit 0
- _ `xor` _ = Bit 1
+ xor = cf2 xor
  {-# INLINE xor #-}
- complement (Bit 0) = Bit 1
- complement _ = Bit 0
+ complement = cf complement
  {-# INLINE complement #-}
  shift !b 0 = b
  shift _ _ = Bit 0
  {-# INLINE shift #-}
  rotate !b _ = b
  {-# INLINE rotate #-}
- zeroBits = Bit 0
+ zeroBits = zero
  {-# INLINE zeroBits #-}
- bit 0 = Bit 1
- bit _ = Bit 0
+ bit 0 = one
+ bit _ = zero
  {-# INLINE bit #-}
- testBit (Bit 1) 0 = True
+ testBit (Bit b) 0 = b /= 0
  testBit _ _ = False
  {-# INLINE testBit #-}
  bitSizeMaybe _ = Just 1
@@ -119,24 +116,23 @@ fromNum _ = one
 
 
 zero :: Bit
-zero = Bit 0
+zero = coerce (0x00 :: Word8)
 {-# INLINE zero #-}
 
 one :: Bit
-one = Bit 1
+one = coerce (0xff :: Word8)
 {-# INLINE one #-}
 
 
 -- | Values: @0@ and @1@
 instance Elevator Bit where
- minValue = Bit 0
+ minValue = Bit 0x00
  {-# INLINE minValue #-}
- maxValue = Bit 1
+ maxValue = Bit 0xff
  {-# INLINE maxValue #-}
  toShowS (Bit 0) = ('0':)
  toShowS _ = ('1':)
- toWord8 (Bit 0) = 0
- toWord8 _ = maxBound
+ toWord8 = coerce
  {-# INLINE toWord8 #-}
  toWord16 (Bit 0) = 0
  toWord16 _ = maxBound
@@ -153,10 +149,10 @@ instance Elevator Bit where
  toRealFloat (Bit 0) = 0
  toRealFloat _ = 1
  {-# INLINE toRealFloat #-}
- fromRealFloat 0 = Bit 0
- fromRealFloat _ = Bit 1
+ fromRealFloat 0 = zero
+ fromRealFloat _ = one
  {-# INLINE fromRealFloat #-}
- (//) (Bit x) (Bit y) = Bit (x `div` y)
+ (//) = cf2 div
  {-# INLINE (//) #-}
 
 
@@ -167,18 +163,18 @@ instance Num Bit where
  -- 0 - 1 = 0
  -- 1 - 0 = 1
  -- 1 - 1 = 0
- (Bit 0) - (Bit 0) = Bit 0
- _ - (Bit 0) = Bit 1
- _ - _ = Bit 0
+ (Bit 0) - (Bit 0) = zero
+ _ - (Bit 0) = one
+ _ - _ = zero
  {-# INLINE (-) #-}
  (*) = (.&.)
  {-# INLINE (*) #-}
  abs = id
  {-# INLINE abs #-}
  signum = id
  {-# INLINE signum #-}
- fromInteger 0 = Bit 0
- fromInteger _ = Bit 1
+ fromInteger 0 = zero
+ fromInteger _ = one
  {-# INLINE fromInteger #-}
 
 -- | Unboxing of a `Bit`.

Color/src/Graphics/Color/Model.hs

@@ -8,6 +8,7 @@
 --
 module Graphics.Color.Model
  ( ColorModel(..)
+ , channelRgbColors
  -- * Alpha
  , Alpha
  , Opaque
@@ -50,3 +51,13 @@ import Graphics.Color.Model.Internal
 import Graphics.Color.Model.RGB
 import Graphics.Color.Model.X
 import Graphics.Color.Model.YCbCr
+import Data.Coerce
+import Data.Proxy
+import Data.List.NonEmpty
+
+-- | Uses `channelColors` to produce actual `RGB` colors for each
+-- channel. Useful for plotting.
+--
+-- @0.4.0
+channelRgbColors :: ColorModel cs e => Proxy (Color cs e) -> NonEmpty (Color RGB Word8)
+channelRgbColors = coerce . channelColors

Color/src/Graphics/Color/Model/CMYK.hs

@@ -1,10 +1,11 @@
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 -- |
 -- Module : Graphics.Color.Model.CMYK
@@ -25,6 +26,7 @@ module Graphics.Color.Model.CMYK
  , rgb2cmyk
  ) where
 
+import Data.List.NonEmpty
 import Foreign.Storable
 import Graphics.Color.Model.Internal
 import Graphics.Color.Model.RGB
@@ -55,6 +57,14 @@ instance Elevator e => Show (Color CMYK e) where
 -- | `CMYK` color model
 instance Elevator e => ColorModel CMYK e where
  type Components CMYK e = (e, e, e, e)
+ type ChannelCount CMYK = 4
+ channelCount _ = 4
+ {-# INLINE channelCount #-}
+ channelNames _ = "Cyan" :| ["Magenta", "Yellow", "Key"]
+ channelColors _ = V3 0x00 0xff 0xff :|
+ [ V3 0xff 0x00 0xff
+ , V3 0xff 0xff 0x00
+ , V3 0xff 0xff 0xff ]
  toComponents (ColorCMYK c m y k) = (c, m, y, k)
  {-# INLINE toComponents #-}
  fromComponents (c, m, y, k) = ColorCMYK c m y k
@@ -69,7 +79,7 @@ instance Functor (Color CMYK) where
 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)
+ ColorCMYK fc fm fy fk <*> ColorCMYK c m y k = ColorCMYK (fc c) (fm m) (fy y) (fk k)
  {-# INLINE (<*>) #-}
 
 -- | `CMYK` color model

Color/src/Graphics/Color/Model/HSI.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -23,12 +24,13 @@ module Graphics.Color.Model.HSI
  , pattern ColorHSI
  , pattern ColorHSIA
  , pattern ColorH360SI
- , Color
+ , Color(..)
  , ColorModel(..)
  , hsi2rgb
  , rgb2hsi
  ) where
 
+import Data.List.NonEmpty
 import Foreign.Storable
 import Graphics.Color.Model.Internal
 import Graphics.Color.Model.RGB
@@ -85,6 +87,11 @@ instance Elevator e => Show (Color HSI e) where
 -- | `HSI` color model
 instance Elevator e => ColorModel HSI e where
  type Components HSI e = (e, e, e)
+ type ChannelCount HSI = 3
+ channelCount _ = 3
+ {-# INLINE channelCount #-}
+ channelNames _ = "Hue" :| ["Saturation", "Intensity"]
+ channelColors _ = V3 0x94 0x00 0xd3 :| [V3 0xff 0x8c 0x00, V3 0x00 0xce 0xd1]
  toComponents (ColorHSI h s i) = (h, s, i)
  {-# INLINE toComponents #-}
  fromComponents (h, s, i) = ColorHSI h s i

Color/src/Graphics/Color/Model/HSL.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -23,13 +24,14 @@ module Graphics.Color.Model.HSL
  , pattern ColorHSL
  , pattern ColorHSLA
  , pattern ColorH360SL
- , Color
+ , Color(..)
  , ColorModel(..)
  , hc2rgb
  , hsl2rgb
  , rgb2hsl
  ) where
 
+import Data.List.NonEmpty
 import Foreign.Storable
 import Graphics.Color.Model.HSV (hc2rgb)
 import Graphics.Color.Model.Internal
@@ -86,6 +88,11 @@ instance Elevator e => Show (Color HSL e) where
 -- | `HSL` color model
 instance Elevator e => ColorModel HSL e where
  type Components HSL e = (e, e, e)
+ type ChannelCount HSL = 3
+ channelCount _ = 3
+ {-# INLINE channelCount #-}
+ channelNames _ = "Hue" :| ["Saturation", "Lightness"]
+ channelColors _ = V3 0x94 0x00 0xd3 :| [V3 0xff 0x8c 0x00, V3 0xaf 0xee 0xee]
  toComponents (ColorHSL h s l) = (h, s, l)
  {-# INLINE toComponents #-}
  fromComponents (h, s, l) = ColorHSL h s l