diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ `prizm` is a Haskell library for transforming colors. Specifically, providing functions for transforming between different color spaces (`CIE` and `sRGB`), -interpolating colors and adjusting the tint, shade, hue, or lightness or a +interpolating colors and adjusting the tint, shade, hue, or lightness of a color. The inspiration for this library came from a desire to blend two colors @@ -14,11 +14,36 @@ accurately represents how the human eye sees hue and therefore preserves (and blends) hue the most accurately. -## Colour Module -There is a bit of overlap with the Haskell Colour Module; however, this library -is filling a couple of needs the other doesn't satisfy. Primarily -transformations and color mutations in the `CIE L*Ch` space. +## Quickstart +```haskell +{-# LANGUAGE ScopedTypeVariables #-} +import Data.Convertible +import Data.Prizm.Color +import Data.Prizm.Color.CIE as CIE + +main = do + -- Convert RGB colors to the CIE.LCH color space + let green :: CIE.LCH = convert $ RGB 102 255 0 + pink :: CIE.LCH = convert $ RGB 255 0 255 + + -- Blend with a weight of 50% + blended50 = pink <~> green + + -- Blend with a weight of 20% + blended20 = interpolate 20 (pink,green) + + -- Print the CIE.LCH representation + putStrLn $ show blended50 + + -- Print the RGB representation of the blended color + putStrLn . show $ (convert blended20) :: RGB + + -- Print the CSS-friendly hexadecimal RGB representation of the blended color + putStrLn . show $ (convert blended20) :: Hex + +``` + ## Supported Algorithms - `sRGB <-> CIE XYZ ` - `CIE XYZ <-> CIE L*ab` @@ -31,10 +56,12 @@ - Hue - Chroma/Saturation -All of these functions operate on color within the `CIE L*Ch` -representation. The percentage values may range between -100 and 100. +## Examples +[Example blending with CIELCH converted back to RGB](./blending-test.html). -- [General Color Formulas, Data, and Algorithms](http://www.brucelindbloom.com/index.html?Info.html) +# References +- [General Color Formulas, Data, and Algorithms](http://www.brucelindbloom.com) - [CIE Conversion Mathematics](http://rip94550.wordpress.com/2011/07/04/color-cielab-and-tristimulus-xyz/) - [Conversion Algorithm Sources](http://www.easyrgb.com/index.php?X=MATH&H=01) - [Good list of useful color manipulation formulas](https://github.com/mikeemoo/ColorJizz-PHP/blob/master/src/MischiefCollective/ColorJizz/ColorJizz.php) + diff --git a/prizm.cabal b/prizm.cabal --- a/prizm.cabal +++ b/prizm.cabal @@ -1,6 +1,6 @@ name: prizm -version: 1.1.0 -synopsis: Color transformations in different color spaces +version: 2.0.0 +synopsis: Convert colors to different color spaces, interpolate colors, and transform colors homepage: https://github.com/ixmatus/prizm license: BSD3 license-file: LICENSE @@ -19,7 +19,7 @@ @prizm@ is a Haskell library for transforming colors. Specifically, providing functions for transforming between different color spaces (@CIE@ and @sRGB@), interpolating colors and adjusting the tint, - shade, hue, or lightness or a color. + shade, hue, or lightness of a color. . The inspiration for this library came from a desire to blend two colors represented in the @sRGB@ color space. My research about color @@ -28,44 +28,6 @@ for blending because it most accurately represents how the human eye sees hue and therefore preserves (and blends) hue the most accurately. - . - /Colour Module/ - . - There is a bit of overlap with the Haskell Colour Module; however, - this library is filling a couple of needs the other doesn't - satisfy. Primarily transformations and color mutations in the @CIE - L*Ch@ space. - . - /Supported Algorithms & Functions/ - . - All of these functions operate on color within the @CIE L*Ch@ color - space. The percentage values may range between -100 and 100. - . - * @sRGB <-> CIE XYZ @ - . - * @CIE XYZ <-> CIE L*ab@ - . - * @CIE L*ab <-> CIE L*Ch@ - . - * Color interpolation - . - * Tinting / Darkening - . - * Lightness - . - * Hue - . - * Chroma/Saturation - . - /Formulas, Resources, and Links/ - . - * - . - * - . - * - . - * extra-source-files: LICENSE @@ -78,14 +40,18 @@ library hs-source-dirs: src default-language: Haskell2010 + other-modules: + Data.Prizm.Color.CIE.Types + Data.Prizm.Color.Constants + Data.Prizm.Color.Matrices.RGB + Data.Prizm.Color.Matrices.XYZ + Data.Prizm.Color.RGB.Types exposed-modules: - Data.Prizm.Types Data.Prizm.Color - Data.Prizm.Color.Transform - Data.Prizm.Color.SRGB Data.Prizm.Color.CIE - Data.Prizm.Color.Matrices.RGB - Data.Prizm.Color.Matrices.XYZ + Data.Prizm.Color.RGB + Data.Prizm.Color.Transform + Data.Prizm.Types ghc-options: -Wall -fno-warn-orphans @@ -101,8 +67,10 @@ main-is: Test.hs default-language: Haskell2010 other-modules: - QC.SRGB - QC.CIE + QC.RGB + QC.CIE + HUnit.Blending + ghc-options: -Wall -threaded -rtsopts @@ -111,6 +79,7 @@ prizm, base >= 4, QuickCheck >= 2.5, + HUnit >= 1.5, convertible >= 1.1, test-framework >= 0.8, mono-traversable >= 1.0, diff --git a/src/Data/Prizm/Color.hs b/src/Data/Prizm/Color.hs --- a/src/Data/Prizm/Color.hs +++ b/src/Data/Prizm/Color.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ConstrainedClassMethods #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Prizm.Color @@ -6,33 +8,147 @@ -- Maintainer : Parnell Springmeyer -- Stability : stable -- --- 'Data.Prizm.Color' exports instances for blending colors, --- convenience blending ('tint' and 'shade'), and adjusting the 'hue', --- 'lightness', or 'chroma' of a given color. +-- @Data.Prizm.Color@ exports all of the specific color space modules +-- and types for blending colors, convenience blending ('tint' and +-- 'shade'), and adjusting the 'hue', 'lightness', or 'chroma' of a +-- given color. You should import this module. -- --- Currently, there are only instances for colors in the in @CIE L*Ch@ --- color space. The reason for this is because the @CIE L*Ch@ color --- space represents the hue of a color closest to how the human eye --- perceives it. Blending and transforming a color in @CIE L*Ch@ --- maintains the brightness of the colors more accurately than the --- other color spaces. +-- Note that blending colors in a polar-coordinate color space, such +-- as 'CIELCH', preserves the saturation and brightness of the colors +-- being interpolated better than blending in RGB. It also turns out +-- to be an effective even when converting from 'RGB' to 'CIELCH', +-- blending, then converting back again! -- --- Here is a link to a blog post by someone detailing the differences --- and documenting them well: --- . +-- Here is an excellent blog post by someone discussing the differences: +-- . ---------------------------------------------------------------------------- module Data.Prizm.Color ( --- * Convertible Instances +-- * Color Transformations + interpolate +, (<~>) +, shade +, tint +, lightness +, chroma +, hue +-- * Preset Colors +, white +, black +-- * Individual Color Spaces -- ** CIE Color Space - module Data.Prizm.Color.CIE --- ** SRGB Color Space -, module Data.Prizm.Color.SRGB --- * Types +, module Data.Prizm.Color.CIE +-- ** RGB Color Space +, module Data.Prizm.Color.RGB +-- * Package Types (re-exports the individual color space type modules too) , module Data.Prizm.Types ) where -import Data.Prizm.Color.CIE hiding (clamp) -import Data.Prizm.Color.SRGB hiding (clamp) +import Data.MonoTraversable +import Data.Prizm.Color.CIE () +import qualified Data.Prizm.Color.CIE as CIE +import Data.Prizm.Color.RGB () import Data.Prizm.Types + +-- | Preset white and black for a color space. +class PresetColor c where + white :: c + black :: c + +-- | A blendable color. +class BlendableColor c where + + -- | Linear interpolation of a color with another color, applying a + -- weight. + interpolate :: Percent -> (c,c) -> c + + -- | Blend two 'BlendableColor' colors using an interpolation weight + -- of 50%. + (<~>) :: c -> c -> c + (<~>) l r = interpolate 50 (l,r) + + -- | Shade a color by blending it using a weight and the + -- @PresetColor@ black. + shade :: PresetColor c => c -> Percent -> c + shade c w = interpolate (pctClamp w) (c, black) + + -- | Tint a color by blending it using a weight and the + -- @PresetColor@ white. + tint :: PresetColor c => c -> Percent -> c + tint c w = interpolate (pctClamp w) (c, white) + +-- | An adjustable color. +class AdjustableColor c where + -- | Adjust the lightness of a color + lightness :: c -> Percent -> c + + -- | Adjust the chroma of a color + -- + -- NB: not all color spaces will support this easily but it should + -- be possible to convert into a color space that does then convert + -- back + chroma :: c -> Percent -> c + + -- | Adjust the hue of a color + hue :: c -> Percent -> c + +instance PresetColor CIE.LCH where + white = CIE.LCH 0.0 0.0 360.0 + black = CIE.LCH 100.0 0.0 360.0 + +instance PresetColor RGB where + white = RGB 255 255 255 + black = RGB 0 0 0 + +instance BlendableColor CIE.LCH where + -- | Interpolate two colors in the @CIE L*C*h@ color space with a + -- weight. + -- + -- Weight is applied left to right, so if a weight of 25% is supplied, + -- then the color on the left will be multiplied by 25% and the second + -- color will be multiplied by 75%. + interpolate w ((CIE.LCH al ac ah), (CIE.LCH bl bc bh)) = + let w' = pct w + (CIE.LCH nl nc nh) = omap (*w') (CIE.LCH (bl - al) (bc - ac) (shortestPath (bh - ah))) + in CIE.LCH (al + nl) (ac + nc) (ah + nh) + +instance AdjustableColor CIE.LCH where + -- | Adjust the lightness / darkness of a color. + lightness (CIE.LCH l c h) w = + CIE.LCH (clamp (l + (100*(pct (pctClamp w)))) 100.0) c h + + -- | Adjust the hue of a color. + hue (CIE.LCH l c h) w = + CIE.LCH l c (clamp (h + (360*(pct (pctClamp w)))) 360.0) + + -- | Adjust the saturation/chroma of a color. + -- + -- A maximum chroma value of 120 is assumed here, anything more is + -- generally considered out of gamut. + chroma (CIE.LCH l c h) w = + CIE.LCH l (clamp (c + (120*(pct (pctClamp w)))) 120.0) h + +------------------------------------------------------------------------------ +-- Utilities +------------------------------------------------------------------------------ +-- | Give the shortest path to the hue value. +shortestPath :: Double -> Double +shortestPath h | h > 180 = h - 360 + | h < (-180) = h + 360 + | otherwise = h + +-- | Give the decimal value for the given "percent" value. +-- +-- The @Percent@ value may range from -100 to 100. +pct :: Percent -> Double +pct i = fromIntegral m / 100 + where + m = pctClamp i + +-- | Clamp a 'Percent' value in the range -100 to 100. +pctClamp :: Percent -> Percent +pctClamp i = max (min i 100) (-100) + +-- | Clamp a 'Double' with a bottom of at least 0.0. +clamp :: Double -> Double -> Double +clamp i clmp = max (min i clmp) 0.0 diff --git a/src/Data/Prizm/Color/CIE.hs b/src/Data/Prizm/Color/CIE.hs --- a/src/Data/Prizm/Color/CIE.hs +++ b/src/Data/Prizm/Color/CIE.hs @@ -10,213 +10,188 @@ -- Maintainer : Parnell Springmeyer -- Stability : stable -- --- Basic utility functions for the @CIE@ transformations and @CIE@ --- convertible instances between the different color space --- representations within @CIE@ and @RGB@. +-- 'Convertible' instances for converting to and from colors in one of +-- the CIE color space representations provided by this library: +-- * 'CIEXYZ' +-- * 'CIELAB' +-- * 'CIELCH' ---------------------------------------------------------------------------- module Data.Prizm.Color.CIE -( clamp -, refWhite -, toRGBMatrix -, transformLAB -, calcLCHHue -, transformRGB -, transformXYZ -, v1 -, v2 +( module Data.Prizm.Color.CIE.Types ) where import Control.Applicative import Data.Convertible.Base import Data.Convertible.Utils -import Data.MonoTraversable +import Data.Prizm.Color.CIE.Types +import Data.Prizm.Color.CIE.Types as CIE +import qualified Data.Prizm.Color.Constants as Constants import Data.Prizm.Color.Matrices.XYZ -import qualified Data.Prizm.Color.SRGB as S +import qualified Data.Prizm.Color.RGB as RGB import Data.Prizm.Color.Transform import Data.Prizm.Types -instance PresetColor CIELCH where - white = CIELCH 0.0 0.0 360.0 - black = CIELCH 100.0 0.0 360.0 - -instance BlendableColor CIELCH where - -- | Interpolate two colors in the @CIE L*C*h@ color space with a - -- weight. - -- - -- Weight is applied left to right, so if a weight of 25% is supplied, - -- then the color on the left will be multiplied by 25% and the second - -- color will be multiplied by 75%. - interpolate w ((CIELCH al ac ah), (CIELCH bl bc bh)) = - let w' = pct w - (CIELCH nl nc nh) = omap (*w') (CIELCH (bl - al) (bc - ac) (shortestPath (bh - ah))) - in CIELCH (al + nl) (ac + nc) (ah + nh) - -instance AdjustableColor CIELCH where - -- | Adjust the lightness / darkness of a color. - lightness (CIELCH l c h) w = - CIELCH (clamp (l + (100*(pct (pctClamp w)))) 100.0) c h - - -- | Adjust the hue of a color. - hue (CIELCH l c h) w = - CIELCH l c (clamp (h + (360*(pct (pctClamp w)))) 360.0) - - -- | Adjust the saturation/chroma of a color. - -- - -- A maximum chroma value of 120 is assumed here, anything more is - -- generally considered out of gamut. - chroma (CIELCH l c h) w = - CIELCH l (clamp (c + (120*(pct (pctClamp w)))) 120.0) h - ------------------------------------------------------------------------------ -- Utilities ------------------------------------------------------------------------------ -clamp :: Double -> Double -> Double -clamp i clmp = max (min i clmp) 0.0 - --- | Exact rational of the "0.008856" value. -v1 :: Double -v1 = (6/29) ** 3 - --- | Exact rational of the "7.787" value. -v2 :: Double -v2 = 1/3 * ((29/6) ** 2) - --- | Reference white, 2deg observer, d65 illuminant. +-- | Reference white, 2° observer, d65 illuminant. -- --- @[x,y,z]@ +-- These values came from Bruce Lindbloom's website: -- -- TODO: this should probably be a triple. +-- TODO: move to another module and make the reference white +-- parameterizable by type so different references can be used! +-- +-- @[x,y,z]@ +-- +-- For future reference (also found in the above linked website), here +-- is a list of reference white illuminant values: +-- +-- * @A 1.09850 1.00000 0.35585@ +-- * @B 0.99072 1.00000 0.85223@ +-- * @C 0.98074 1.00000 1.18232@ +-- * @D50 0.96422 1.00000 0.82521@ +-- * @D55 0.95682 1.00000 0.92149@ +-- * @D65 0.95047 1.00000 1.08883@ +-- * @D75 0.94972 1.00000 1.22638@ +-- * @E 1.00000 1.00000 1.00000@ +-- * @F2 0.99186 1.00000 0.67393@ +-- * @F7 0.95041 1.00000 1.08747@ +-- * @F11 1.00962 1.00000 0.64350@ refWhite :: [Double] refWhite = [95.047, 100.000, 108.883] --- | Transform a 'CIEXYZ' point. +-- | Transform a 'CIE.XYZ' point. -- -- TODO: should provide *much* better documentation on what this is -- actually doing in the algorithms. transformXYZ :: Double -> Double -transformXYZ v | cv > v1 = cv - | otherwise = (v - 16 / 116) / v2 +transformXYZ v | cv > Constants.ζ = cv + | otherwise = (v - 16 / 116) / Constants.ξ where cv = v**3 --- | Calculate the hue for a conversion to 'CIELCH' from the 'atan2' --- of the *a* and *b* color opponents of a 'CIELAB' color. +-- | Calculate the hue for a conversion to 'CIE.LCH' from the 'atan2' +-- of the *a* and *b* color opponents of a 'CIE.LAB' color. -- -- TODO: should provide *much* better documentation on what this is -- actually doing in the algorithms. calcLCHHue :: Double -> Double -calcLCHHue v | v > 0 = (v / pi) * 180 +calcLCHHue v | v > 0 = (v / pi) * 180 | otherwise = 360 - ((abs v) / pi) * 180 --- | Transform a 'CIELAB' point. +-- | Transform a 'CIE.LAB' point. -- -- TODO: should provide *much* better documentation on what this is -- actually doing in the algorithms. transformLAB :: Double -> Double -transformLAB v | v > v1 = v ** (1/3) - | otherwise = (v2 * v) + (16 / 116) +transformLAB v | v > Constants.ζ = v ** (1/3) + | otherwise = (Constants.ξ * v) + (16 / 116) --- | Transform an 'CIEXYZ' 'Double' to be computed against the +-- | Transform an 'CIE.XYZ' 'Double' to be computed against the -- xyzToRGB matrix. transformRGB :: Double -> Integer transformRGB v | v > 0.0031308 = min (round (255 * (1.055 * (v ** (1 / 2.4)) - 0.055))) 255 | otherwise = min (round (255 * (12.92 * v))) 255 --- | Convert an XYZ color to an SRGB color. +-- | Convert an XYZ color to an RGB color. -- -- 'XYZtoRGB' is the pre-calculated illuminant matrix, it is -- preferable to use 'toRG' as it uses the most "common" one. -toRGBMatrix :: XYZtoRGB -> CIEXYZ -> RGB -toRGBMatrix (XYZtoRGB m) (CIEXYZ x y z) = +toRGBMatrix :: XYZtoRGB -> CIE.XYZ -> RGB +toRGBMatrix (XYZtoRGB m) (CIE.XYZ x y z) = let t = ZipList ((/100) <$> [x,y,z]) -- NB: be sure to clamp before converting to a Word8, -- otherwise we can overflow! - [r,g,b] = (fromIntegral . S.clamp . transformRGB) <$> ((zipTransform t) <$> m) + [r,g,b] = (fromIntegral . RGB.clamp . transformRGB) <$> ((zipTransform t) <$> m) in RGB r g b ------------------------------------------------------------------------------ -- Convertible ------------------------------------------------------------------------------ - -instance Convertible CIELAB CIELCH where - -- | Convert a 'CIELAB' to a 'CIELCH' - safeConvert (CIELAB l a b) = +instance Convertible CIE.LAB CIE.LCH where + -- | Convert a 'CIE.LAB' to a 'CIE.LCH' + safeConvert (CIE.LAB l a b) = let h = calcLCHHue (atan2 b a) c = sqrt ((a^(2 :: Int)) + (b^(2 :: Int))) - in Right $ CIELCH l c h + in Right $ CIE.LCH l c h -instance Convertible CIELAB CIEXYZ where - -- | Convert a 'CIELAB' to a 'CIEXYZ' - safeConvert (CIELAB l a b) = +instance Convertible CIE.LAB CIE.XYZ where + -- | Convert a 'CIE.LAB' to a 'CIE.XYZ' + safeConvert (CIE.LAB l a b) = let y = (l + 16) / 116 x = a / 500 + y z = y - b / 200 [nx,ny,nz] = getZipList $ ((*) <$> ZipList (transformXYZ <$> [x,y,z])) <*> ZipList refWhite - in Right $ CIEXYZ nx ny nz + in Right $ CIE.XYZ nx ny nz -instance Convertible CIELAB RGB where - -- | Convert a 'CIELAB' to a S'RGB' - safeConvert = convertVia (undefined :: CIEXYZ) +instance Convertible CIE.LAB RGB where + -- | Convert a 'CIE.LAB' to a S'RGB' + safeConvert = convertVia (undefined :: CIE.XYZ) -instance Convertible CIELAB Hex where - -- | Convert a 'CIELAB' to an S'RGB' hexadecimal color +instance Convertible CIE.LAB Hex where + -- | Convert a 'CIE.LAB' to an S'RGB' hexadecimal color safeConvert = convertVia (undefined :: RGB) -instance Convertible RGB CIELAB where - -- | Convert a S'RGB' to a 'CIELAB' - safeConvert = convertVia (undefined :: CIEXYZ) +instance Convertible RGB CIE.LAB where + -- | Convert a S'RGB' to a 'CIE.LAB' + safeConvert = convertVia (undefined :: CIE.XYZ) -instance Convertible RGB CIELCH where - -- | Convert a S'RGB' to a 'CIELCH' - safeConvert = convertVia (undefined :: CIELAB) +instance Convertible RGB CIE.LCH where + -- | Convert a S'RGB' to a 'CIE.LCH' + safeConvert = convertVia (undefined :: CIE.LAB) -instance Convertible Hex CIELAB where - -- | Convert an S'RGB' hexadecimal color to a 'CIELAB' +instance Convertible Hex CIE.LAB where + -- | Convert an S'RGB' hexadecimal color to a 'CIE.LAB' safeConvert = convertVia (undefined :: RGB) -instance Convertible Hex CIELCH where - -- | Convert an S'RGB' hexadecimal color to a 'CIELCH' +instance Convertible Hex CIE.LCH where + -- | Convert an S'RGB' hexadecimal color to a 'CIE.LCH' safeConvert = convertVia (undefined :: RGB) -instance Convertible CIELCH CIELAB where - -- | Convert a 'CIELCH' to a 'CIELAB' - safeConvert (CIELCH l c h) = +instance Convertible CIE.LCH CIE.LAB where + -- | Convert a 'CIE.LCH' to a 'CIE.LAB' + safeConvert (CIE.LCH l c h) = let v = h * pi / 180 - in Right $ CIELAB l ((cos v)*c) ((sin v)*c) + in Right $ CIE.LAB l ((cos v)*c) ((sin v)*c) -instance Convertible CIELCH RGB where - -- | Convert a 'CIELCH' to a S'RGB' - safeConvert = convertVia (undefined :: CIELAB) +instance Convertible CIE.LCH RGB where + -- | Convert a 'CIE.LCH' to a S'RGB' + safeConvert = convertVia (undefined :: CIE.LAB) -instance Convertible CIELCH CIEXYZ where - safeConvert = convertVia (undefined :: CIELAB) +instance Convertible CIE.LCH Hex where + -- | Convert a 'CIE.LCH' to a RGB hexadecimal representation + safeConvert = convertVia (undefined :: RGB) -instance Convertible CIEXYZ RGB where - -- | Convert a 'CIEXYZ' to an S'RGB' +instance Convertible CIE.LCH CIE.XYZ where + safeConvert = convertVia (undefined :: CIE.LAB) + +instance Convertible CIE.XYZ RGB where + -- | Convert a 'CIE.XYZ' to an S'RGB' -- -- This function uses the default d65 illuminant matrix. safeConvert = Right . toRGBMatrix d65SRGB -instance Convertible CIEXYZ Hex where - -- | Convert a 'CIEXYZ' to an S'RGB' hexadecimal color +instance Convertible CIE.XYZ Hex where + -- | Convert a 'CIE.XYZ' to an S'RGB' hexadecimal color safeConvert = convertVia (undefined :: RGB) -instance Convertible CIEXYZ CIELCH where - -- | Convert a 'CIEXYZ' to a 'CIELCH' via 'CIELAB' - safeConvert = convertVia (undefined :: CIELAB) +instance Convertible CIE.XYZ CIE.LCH where + -- | Convert a 'CIE.XYZ' to a 'CIE.LCH' via 'CIE.LAB' + safeConvert = convertVia (undefined :: CIE.LAB) -instance Convertible CIEXYZ CIELAB where - -- | Convert an 'CIEXYZ' to a 'CIELAB' +instance Convertible CIE.XYZ CIE.LAB where + -- | Convert an 'CIE.XYZ' to a 'CIE.LAB' -- -- This function uses the default reference white (2deg observer, -- d65 illuminant). - safeConvert (CIEXYZ x y z) = + safeConvert (CIE.XYZ x y z) = let v = getZipList $ ZipList ((/) <$> [x,y,z]) <*> ZipList refWhite [tx,ty,tz] = (transformLAB) <$> v l = (116 * ty) - 16 a = 500 * (tx - ty) b = 200 * (ty - tz) - in Right $ CIELAB l a b + in Right $ CIE.LAB l a b -instance Convertible Hex CIEXYZ where - -- | Convert a hexadecimal S'RGB' color to a 'CIEXYZ' +instance Convertible Hex CIE.XYZ where + -- | Convert a hexadecimal S'RGB' color to a 'CIE.XYZ' safeConvert = convertVia (undefined :: RGB) diff --git a/src/Data/Prizm/Color/CIE/Types.hs b/src/Data/Prizm/Color/CIE/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prizm/Color/CIE/Types.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Prizm.Color.CIE.Types +-- Copyright : (C) 2017 Parnell Springmeyer +-- License : BSD3 +-- Maintainer : Parnell Springmeyer +-- Stability : stable +----------------------------------------------------------------------------- +module Data.Prizm.Color.CIE.Types where + +import Data.MonoTraversable + +-- | A color in the @CIE XYZ@ color space. +data XYZ = XYZ !Double !Double !Double + deriving (Eq, Ord, Show) + +-- | A color in the @CIE L*a*b*@ color space. +data LAB = LAB !Double !Double !Double + deriving (Eq, Ord, Show) + +-- | A color in the @CIE L*C*h(uv)@ color space. +data LCH = LCH !Double !Double !Double + deriving (Eq, Ord, Show) + +type instance Element XYZ = Double +type instance Element LCH = Double +type instance Element LAB = Double + +instance MonoFunctor XYZ where + omap f (XYZ x y z) = XYZ (f x) (f y) (f z) +instance MonoFunctor LAB where + omap f (LAB l a b) = LAB (f l) (f a) (f b) +instance MonoFunctor LCH where + omap f (LCH l c h) = LCH (f l) (f c) (f h) diff --git a/src/Data/Prizm/Color/Constants.hs b/src/Data/Prizm/Color/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prizm/Color/Constants.hs @@ -0,0 +1,18 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Prizm.Color.Constants +-- Copyright : (C) 2017 Parnell Springmeyer +-- License : BSD3 +-- Maintainer : Parnell Springmeyer +-- Stability : stable +-- +---------------------------------------------------------------------------- +module Data.Prizm.Color.Constants where + +-- | Exact rational of the "0.008856" value. +ζ :: Double +ζ = (6/29) ** 3 + +-- | Exact rational of the "7.787" value. +ξ :: Double +ξ = 1/3 * ((29/6) ** 2) diff --git a/src/Data/Prizm/Color/RGB.hs b/src/Data/Prizm/Color/RGB.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prizm/Color/RGB.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Prizm.Color.RGB +-- Copyright : (C) 2013 Parnell Springmeyer +-- License : BSD3 +-- Maintainer : Parnell Springmeyer +-- Stability : stable +-- +-- Transformation functions and convenience functions to do the base +-- conversion between 'RGB' and 'CIEXYZ'. +---------------------------------------------------------------------------- +module Data.Prizm.Color.RGB +( clamp +, module Data.Prizm.Color.RGB.Types +) where + +import Control.Applicative +import Data.Convertible.Base +import Data.Monoid +import Data.Prizm.Color.CIE.Types as CIE +import Data.Prizm.Color.Matrices.RGB +import Data.Prizm.Color.RGB.Types +import Data.Prizm.Color.Transform +import Data.Prizm.Types +import Data.String +import qualified Data.Text as T +import Data.Text.Read as R +import Numeric (showHex) + +------------------------------------------------------------------------------ +-- Utilities +------------------------------------------------------------------------------ +-- | Transform an RGB integer to be computed against a matrix. +transform :: Integer -> Double +transform v | dv > 0.04045 = (((dv + 0.055) / ap) ** 2.4) * 100 + | otherwise = (dv / 12.92) * 100 + where dv = fromIntegral v / 255 + ap = 1.0 + 0.055 + +-- | Clamp a 'Word8' with an upper-bound of 255 (the maximum RGB +-- value). +clamp :: Integral a => a -> a +clamp i = max (min i 255) 0 + +-- All credit for the below three functions go to the HSColour module. + +-- | Show a colour in hexadecimal form, e.g. @#00aaff@ +showRGB :: RGB -> Hex +showRGB c = + (("#"++) . showHex2 r' . showHex2 g' . showHex2 b') "" + where + (RGB r' g' b') = c + showHex2 x | x <= 0xf = ("0"++) . showHex x + | otherwise = showHex x + +-- | Parse a 'Hex' into an s'RGB' type. +parse :: T.Text -> RGB +parse t = + case T.uncons t of + Just ('#', cs) | T.all isHex cs -> + case T.unpack cs of + [a, b, c, d, e, f, _g, _h] -> RGB (hex a b) (hex c d) (hex e f) + [a, b, c, d, e, f ] -> RGB (hex a b) (hex c d) (hex e f) + [a, b, c, _d ] -> RGB (hex a a) (hex b b) (hex c c) + [a, b, c ] -> RGB (hex a a) (hex b b) (hex c c) + _ -> err + _ -> err + + where + hex a b = either err fst (R.hexadecimal (T.singleton a <> T.singleton b)) + isHex a = (a >= 'a' && a <= 'f') || (a >= 'A' && a <= 'F') || (a >= '0' && a <= '9') + err = error "Invalid color string" + +------------------------------------------------------------------------------ +-- Convertible +------------------------------------------------------------------------------ +instance Convertible RGB CIE.XYZ where + -- | Convert an S'RGB' value to a 'CIE.XYZ' value with the default + -- @d65@ illuminant matrix. + safeConvert = Right . (toXYZMatrix d65SRGB) + +instance Convertible RGB Hex where + -- | Convert an S'RGB' value to a hexadecimal representation. + safeConvert = Right . showRGB + +instance Convertible Hex RGB where + -- | Convert a hexadecimal value to an S'RGB'. + safeConvert = Right . parse . fromString + +-- | Convert an s'RGB' value to a 'CIE.XYZ' given a pre-calculated +-- illuminant matrix. +toXYZMatrix :: RGBtoXYZ -> RGB -> CIE.XYZ +toXYZMatrix (RGBtoXYZ m) (RGB r g b) = + let t = ZipList ((transform . fromIntegral) <$> (clamp <$> [r,g,b])) + [x,y,z] = (roundN 3) <$> ((zipTransform t) <$> m) + in CIE.XYZ x y z diff --git a/src/Data/Prizm/Color/RGB/Types.hs b/src/Data/Prizm/Color/RGB/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Prizm/Color/RGB/Types.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Prizm.Color.RGB.Types +-- Copyright : (C) 2017 Parnell Springmeyer +-- License : BSD3 +-- Maintainer : Parnell Springmeyer +-- Stability : stable +----------------------------------------------------------------------------- +module Data.Prizm.Color.RGB.Types where + +import Data.MonoTraversable +import Data.Word + +-- | A color in the @sRGB@ color space. +data RGB = RGB !Word8 !Word8 !Word8 + deriving (Eq, Ord, Show) + +-- | Monomorphic functor instances for the color spaces. +type instance Element RGB = Word8 + +instance MonoFunctor RGB where + omap f (RGB r g b) = RGB (f r) (f g) (f b) diff --git a/src/Data/Prizm/Color/SRGB.hs b/src/Data/Prizm/Color/SRGB.hs deleted file mode 100644 --- a/src/Data/Prizm/Color/SRGB.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} - ------------------------------------------------------------------------------ --- | --- Module : Data.Prizm.Color.SRGB --- Copyright : (C) 2013 Parnell Springmeyer --- License : BSD3 --- Maintainer : Parnell Springmeyer --- Stability : stable --- --- Transformation functions and convenience functions to do the base --- conversion between S'RGB' and 'CIEXYZ'. ----------------------------------------------------------------------------- -module Data.Prizm.Color.SRGB -( clamp -, parse -, showRGB -, toXYZMatrix -, transform -) where - -import Control.Applicative -import Data.Convertible.Base -import Data.Monoid -import Data.Prizm.Color.Matrices.RGB -import Data.Prizm.Color.Transform -import Data.Prizm.Types -import Data.String -import qualified Data.Text as T -import Data.Text.Read as R -import Numeric (showHex) - -instance PresetColor RGB where - white = RGB 255 255 255 - black = RGB 0 0 0 - ------------------------------------------------------------------------------- --- Utilities ------------------------------------------------------------------------------- --- | Transform an RGB integer to be computed against a matrix. -transform :: Integer -> Double -transform v | dv > 0.04045 = (((dv + 0.055) / ap) ** 2.4) * 100 - | otherwise = (dv / 12.92) * 100 - where dv = fromIntegral v / 255 - ap = 1.0 + 0.055 - --- | Clamp a 'Word8' with an upper-bound of 255 (the maximum RGB --- value). -clamp :: Integral a => a -> a -clamp i = max (min i 255) 0 - --- All credit for the below three functions go to the HSColour module. - --- | Show a colour in hexadecimal form, e.g. @#00aaff@ -showRGB :: RGB -> Hex -showRGB c = - (("#"++) . showHex2 r' . showHex2 g' . showHex2 b') "" - where - (RGB r' g' b') = c - showHex2 x | x <= 0xf = ("0"++) . showHex x - | otherwise = showHex x - --- | Parse a 'Hex' into an s'RGB' type. -parse :: T.Text -> RGB -parse t = - case T.uncons t of - Just ('#', cs) | T.all isHex cs -> - case T.unpack cs of - [a, b, c, d, e, f, _g, _h] -> RGB (hex a b) (hex c d) (hex e f) - [a, b, c, d, e, f ] -> RGB (hex a b) (hex c d) (hex e f) - [a, b, c, _d ] -> RGB (hex a a) (hex b b) (hex c c) - [a, b, c ] -> RGB (hex a a) (hex b b) (hex c c) - _ -> err - _ -> err - - where - hex a b = either err fst (R.hexadecimal (T.singleton a <> T.singleton b)) - isHex a = (a >= 'a' && a <= 'f') || (a >= 'A' && a <= 'F') || (a >= '0' && a <= '9') - err = error "Invalid color string" - ------------------------------------------------------------------------------- --- Convertible ------------------------------------------------------------------------------- -instance Convertible RGB CIEXYZ where - -- | Convert an S'RGB' value to a 'CIEXYZ' value with the default - -- @d65@ illuminant matrix. - safeConvert = Right . (toXYZMatrix d65SRGB) - -instance Convertible RGB Hex where - -- | Convert an S'RGB' value to a hexadecimal representation. - safeConvert = Right . showRGB - -instance Convertible Hex RGB where - -- | Convert a hexadecimal value to an S'RGB'. - safeConvert = Right . parse . fromString - --- | Convert an s'RGB' value to a 'CIEXYZ' given a pre-calculated --- illuminant matrix. -toXYZMatrix :: RGBtoXYZ -> RGB -> CIEXYZ -toXYZMatrix (RGBtoXYZ m) (RGB r g b) = - let t = ZipList ((transform . fromIntegral) <$> (clamp <$> [r,g,b])) - [x,y,z] = (roundN 3) <$> ((zipTransform t) <$> m) - in CIEXYZ x y z diff --git a/src/Data/Prizm/Types.hs b/src/Data/Prizm/Types.hs --- a/src/Data/Prizm/Types.hs +++ b/src/Data/Prizm/Types.hs @@ -9,10 +9,21 @@ -- Maintainer : Parnell Springmeyer -- Stability : stable ----------------------------------------------------------------------------- -module Data.Prizm.Types where +module Data.Prizm.Types +( +-- * Generic Utility Types + RGBtoXYZ(..) +, XYZtoRGB(..) +, Hex +, Percent +-- * CIE Color Space Types +, module Data.Prizm.Color.CIE.Types +-- * RGB Color Space Types +, module Data.Prizm.Color.RGB.Types +) where -import Data.MonoTraversable -import Data.Word +import Data.Prizm.Color.CIE.Types +import Data.Prizm.Color.RGB.Types -- | Working space matrix to convert from sRGB to CIE XYZ. newtype RGBtoXYZ = RGBtoXYZ [[Double]] @@ -28,99 +39,3 @@ -- | A percent value ranging from -100 to 100; e.g: -82%, 80%, 10%. type Percent = Integer - --- | A color in the sRGB color space. -data RGB = RGB !Word8 !Word8 !Word8 - deriving (Eq, Ord, Show) - --- | A color in the CIE XYZ color space. -data CIEXYZ = CIEXYZ !Double !Double !Double - deriving (Eq, Ord, Show) - --- | A color in the @CIE L*a*b*@ color space. -data CIELAB = CIELAB !Double !Double !Double - deriving (Eq, Ord, Show) - --- | A color in the @CIE L*C*h(uv)@ color space. -data CIELCH = CIELCH !Double !Double !Double - deriving (Eq, Ord, Show) - --- | Monomorphic functor instances for the color spaces. -type instance Element RGB = Word8 -type instance Element CIEXYZ = Double -type instance Element CIELCH = Double -type instance Element CIELAB = Double - -instance MonoFunctor RGB where - omap f (RGB r g b) = RGB (f r) (f g) (f b) - -instance MonoFunctor CIEXYZ where - omap f (CIEXYZ x y z) = CIEXYZ (f x) (f y) (f z) - -instance MonoFunctor CIELAB where - omap f (CIELAB l a b) = CIELAB (f l) (f a) (f b) - -instance MonoFunctor CIELCH where - omap f (CIELCH l c h) = CIELCH (f l) (f c) (f h) - --- | Preset white and black for a color space. -class PresetColor c where - white :: c - black :: c - --- | A blendable color. -class BlendableColor c where - - -- | Interpolate a color with another color, applying a weight. - interpolate :: Percent -> (c,c) -> c - - -- | Blend two @Blendable@ colors using an interpolation weight of - -- 50%. - (<~>) :: c -> c -> c - (<~>) l r = interpolate 50 (l,r) - - -- | Shade a color by blending it using a weight and the - -- @PresetColor@ black. - shade :: PresetColor c => c -> Percent -> c - shade c w = interpolate (pctClamp w) (c, black) - - -- | Tint a color by blending it using a weight and the - -- @PresetColor@ white. - tint :: PresetColor c => c -> Percent -> c - tint c w = interpolate (pctClamp w) (c, white) - --- | An adjustable color. -class AdjustableColor c where - -- | Adjust the lightness of a color - lightness :: c -> Percent -> c - - -- | Adjust the chroma of a color - -- - -- NB: not all color spaces will support this easily but it should - -- be possible to convert into a color space that does then convert - -- back - chroma :: c -> Percent -> c - - -- | Adjust the hue of a color - hue :: c -> Percent -> c - ------------------------------------------------------------------------------- --- Utilities ------------------------------------------------------------------------------- --- | Give the shortest path to the hue value. -shortestPath :: Double -> Double -shortestPath h | h > 180 = h - 360 - | h < (-180) = h + 360 - | otherwise = h - --- | Give the decimal value for the given "percent" value. --- --- The @Percent@ value may range from -100 to 100. -pct :: Percent -> Double -pct i = fromIntegral m / 100 - where - m = pctClamp i - --- | Clamp a @Percent@ value in the range -100 to 100. -pctClamp :: Percent -> Percent -pctClamp i = max (min i 100) (-100) diff --git a/tests/HUnit/Blending.hs b/tests/HUnit/Blending.hs new file mode 100644 --- /dev/null +++ b/tests/HUnit/Blending.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HUnit.Blending (tests) where + +import Data.Convertible +import Data.Prizm.Color +import Data.Prizm.Color.CIE as CIE +import Test.Framework (Test) +import Test.Framework.Providers.HUnit as HUnit +import Test.HUnit (Assertion, (@?=)) + +tests :: [Test] +tests = + [ testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 0%" $ blendPinkGreen 0 (RGB 255 0 255) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 10%" $ blendPinkGreen 10 (RGB 255 0 210) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 20%" $ blendPinkGreen 20 (RGB 255 0 163) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 30%" $ blendPinkGreen 30 (RGB 255 0 115) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 40%" $ blendPinkGreen 40 (RGB 255 51 67) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 50%" $ blendPinkGreen 50 (RGB 255 111 0) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 60%" $ blendPinkGreen 60 (RGB 255 152 0) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 70%" $ blendPinkGreen 70 (RGB 255 186 0) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 80%" $ blendPinkGreen 80 (RGB 222 213 0) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 90%" $ blendPinkGreen 90 (RGB 172 236 0) + , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 100%" $ blendPinkGreen 100 (RGB 102 255 0) + ] + +blendPinkGreen :: Percent -> RGB -> Assertion +blendPinkGreen pct expected = + let pink :: CIE.LCH = convert $ RGB 255 0 255 + green :: CIE.LCH = convert $ RGB 102 255 0 + blended :: RGB = convert $ interpolate pct (pink,green) + in blended @?= expected diff --git a/tests/QC/CIE.hs b/tests/QC/CIE.hs --- a/tests/QC/CIE.hs +++ b/tests/QC/CIE.hs @@ -8,37 +8,38 @@ import Data.Convertible import Data.MonoTraversable import Data.Prizm.Color +import Data.Prizm.Color.CIE as CIE import Data.Prizm.Color.Transform import Test.Framework (Test) import Test.Framework.Providers.QuickCheck2 as QuickCheck import Test.QuickCheck -instance Arbitrary CIEXYZ where - arbitrary = liftM3 CIEXYZ (choose (0, 95.047)) (choose (0, 100.000)) (choose (0, 108.883)) +instance Arbitrary CIE.XYZ where + arbitrary = liftM3 CIE.XYZ (choose (0, 95.047)) (choose (0, 100.000)) (choose (0, 108.883)) -instance Arbitrary CIELAB where - arbitrary = liftM3 CIELAB (choose (0, 100)) (choose ((-129), 129)) (choose ((-129), 129)) +instance Arbitrary CIE.LAB where + arbitrary = liftM3 CIE.LAB (choose (0, 100)) (choose ((-129), 129)) (choose ((-129), 129)) rN :: Double -> Double rN = roundN 11 -xyz2LAB :: CIEXYZ -> Bool +xyz2LAB :: CIE.XYZ -> Bool xyz2LAB ((omap rN ) -> genVal) = genVal == xyz where ((omap rN) -> xyz) = - convert ((convert genVal) :: CIELAB) + convert ((convert genVal) :: CIE.LAB) -lab2XYZ :: CIELAB -> Bool +lab2XYZ :: CIE.LAB -> Bool lab2XYZ ((omap rN ) -> genVal) = genVal == lab where ((omap rN) -> lab) = - convert ((convert genVal) :: CIEXYZ) + convert ((convert genVal) :: CIE.XYZ) -lab2LCH :: CIELAB -> Bool +lab2LCH :: CIE.LAB -> Bool lab2LCH ((omap rN ) -> genVal) = genVal == lch where ((omap rN) -> lch) = - convert ((convert genVal) :: CIELCH) + convert ((convert genVal) :: CIE.LCH) tests :: [Test] tests = diff --git a/tests/QC/RGB.hs b/tests/QC/RGB.hs new file mode 100644 --- /dev/null +++ b/tests/QC/RGB.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module QC.RGB (tests) where + +import Control.Monad (liftM3) +import Data.Convertible +import Data.Prizm.Color (Hex, RGB (..)) +import Data.Prizm.Color.CIE as CIE +import Test.Framework (Test) +import Test.Framework.Providers.QuickCheck2 as QuickCheck +import Test.QuickCheck + +instance Arbitrary RGB where + arbitrary = liftM3 RGB (choose rgbRange) (choose rgbRange) (choose rgbRange) + where + rgbRange = (0, 255) + +rgb2XYZ :: RGB -> Bool +rgb2XYZ gVal = gVal == iso + where + iso = convert ((convert gVal) :: CIE.XYZ) + +rgb2HEX :: RGB -> Bool +rgb2HEX gVal = gVal == iso + where + iso = convert ((convert gVal) :: Hex) + +tests :: [Test] +tests = + [ QuickCheck.testProperty "RGB <-> CIE XYZ" rgb2XYZ + , QuickCheck.testProperty "HEX <-> RGB " rgb2HEX + ] diff --git a/tests/QC/SRGB.hs b/tests/QC/SRGB.hs deleted file mode 100644 --- a/tests/QC/SRGB.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module QC.SRGB (tests) where - -import Control.Monad (liftM3) -import Data.Convertible -import Data.Prizm.Color -import Test.Framework (Test) -import Test.Framework.Providers.QuickCheck2 as QuickCheck -import Test.QuickCheck - -instance Arbitrary RGB where - arbitrary = liftM3 RGB (choose rgbRange) (choose rgbRange) (choose rgbRange) - where - rgbRange = (0, 255) - -rgb2XYZ :: RGB -> Bool -rgb2XYZ gVal = gVal == iso - where - iso = convert ((convert gVal) :: CIEXYZ) - -rgb2HEX :: RGB -> Bool -rgb2HEX gVal = gVal == iso - where - iso = convert ((convert gVal) :: Hex) - -tests :: [Test] -tests = - [ QuickCheck.testProperty "SRGB <-> CIE XYZ" rgb2XYZ - , QuickCheck.testProperty "HEX <-> SRGB " rgb2HEX - ] diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -2,8 +2,9 @@ module Main (main) where +import qualified HUnit.Blending as Blending import qualified QC.CIE as CIE -import qualified QC.SRGB as SRGB +import qualified QC.RGB as RGB import Test.Framework (Test, defaultMain, testGroup) main :: IO () @@ -11,6 +12,7 @@ tests :: [Test] tests = - [ testGroup "SRGB" SRGB.tests - , testGroup "CIE" CIE.tests + [ testGroup "RGB" RGB.tests + , testGroup "CIE" CIE.tests + , testGroup "Blending" Blending.tests ]