prizm 2.0.1 → 3.0.0
raw patch · 17 files changed
+423/−288 lines, 17 filesdep −mono-traversable
Dependencies removed: mono-traversable
Files
- README.md +10/−8
- prizm.cabal +10/−12
- src/Data/Prizm/Color.hs +18/−21
- src/Data/Prizm/Color/CIE.hs +78/−74
- src/Data/Prizm/Color/CIE/Chroma/Illuminant.hs +69/−0
- src/Data/Prizm/Color/CIE/Matrices/RGB.hs +29/−0
- src/Data/Prizm/Color/CIE/Matrices/XYZ.hs +29/−0
- src/Data/Prizm/Color/CIE/Types.hs +23/−13
- src/Data/Prizm/Color/Matrices/RGB.hs +0/−27
- src/Data/Prizm/Color/Matrices/XYZ.hs +0/−27
- src/Data/Prizm/Color/RGB.hs +53/−44
- src/Data/Prizm/Color/RGB/Types.hs +16/−8
- src/Data/Prizm/Color/Transform.hs +17/−8
- src/Data/Prizm/Types.hs +45/−19
- tests/HUnit/Blending.hs +13/−13
- tests/QC/CIE.hs +8/−9
- tests/QC/RGB.hs +5/−5
README.md view
@@ -18,14 +18,15 @@ ```haskell {-# LANGUAGE ScopedTypeVariables #-} -import Data.Convertible-import Data.Prizm.Color-import Data.Prizm.Color.CIE as CIE+import Data.Convertible+import Data.Prizm.Color+import Data.Prizm.Color.CIE as CIE +main :: IO () 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+ let green :: CIE.LCH = convert $ mkRGB 102 255 0+ pink :: CIE.LCH = convert $ mkRGB 255 0 255 -- Blend with a weight of 50% blended50 = pink <~> green@@ -37,10 +38,11 @@ putStrLn $ show blended50 -- Print the RGB representation of the blended color- putStrLn . show $ (convert blended20) :: RGB+ putStrLn . show $ ((convert blended20) :: RGB) - -- Print the CSS-friendly hexadecimal RGB representation of the blended color- putStrLn . show $ (convert blended20) :: Hex+ -- Print the RGB color in a hexadecimal encoding+ putStrLn . show $ ((convert blended20) :: HexRGB)+ ```
prizm.cabal view
@@ -1,5 +1,5 @@ name: prizm-version: 2.0.1+version: 3.0.0 synopsis: Convert colors to different color spaces, interpolate colors, and transform colors homepage: https://github.com/ixmatus/prizm license: BSD3@@ -40,26 +40,25 @@ 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.Color Data.Prizm.Color.CIE+ Data.Prizm.Color.CIE.Chroma.Illuminant+ Data.Prizm.Color.CIE.Matrices.RGB+ Data.Prizm.Color.CIE.Matrices.XYZ+ Data.Prizm.Color.CIE.Types+ Data.Prizm.Color.Constants Data.Prizm.Color.RGB+ Data.Prizm.Color.RGB.Types Data.Prizm.Color.Transform Data.Prizm.Types ghc-options: -Wall -fno-warn-orphans build-depends:- base >= 4.5 && < 5,- text >= 0.11.2.3,- convertible >= 1.1,- mono-traversable >= 1.0+ base >= 4.5 && < 5,+ text >= 0.11.2.3,+ convertible >= 1.1 test-suite tests type: exitcode-stdio-1.0@@ -82,6 +81,5 @@ HUnit, convertible, test-framework,- mono-traversable, test-framework-quickcheck2, test-framework-hunit
src/Data/Prizm/Color.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -38,10 +39,10 @@ , module Data.Prizm.Types ) where -import Data.MonoTraversable-import Data.Prizm.Color.CIE ()+import Data.Prizm.Color.CIE import qualified Data.Prizm.Color.CIE as CIE-import Data.Prizm.Color.RGB ()+import Data.Prizm.Color.RGB hiding (clamp)+import qualified Data.Prizm.Color.RGB as RGB import Data.Prizm.Types -- | Preset white and black for a color space.@@ -87,12 +88,12 @@ 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+ white = CIE.mkLCH 0.0 0.0 360.0+ black = CIE.mkLCH 100.0 0.0 360.0 -instance PresetColor RGB where- white = RGB 255 255 255- black = RGB 0 0 0+instance PresetColor RGB.RGB where+ white = RGB.mkRGB 255 255 255+ black = RGB.mkRGB 0 0 0 instance BlendableColor CIE.LCH where -- | Interpolate two colors in the @CIE L*C*h@ color space with a@@ -101,26 +102,26 @@ -- 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)) =+ interpolate w ((CIE.unLCH -> ColorCoord(al,ac,ah)), (CIE.unLCH -> ColorCoord(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)+ ColorCoord(nl,nc,nh) = (*w') <$> (ColorCoord((bl - al),(bc - ac),(shortestPath (bh - ah))))+ in CIE.mkLCH (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+ lightness (CIE.unLCH -> ColorCoord(l,c,h)) w =+ CIE.mkLCH (CIE.clamp (l + (100*(pct 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)+ hue (CIE.unLCH -> ColorCoord(l,c,h)) w =+ CIE.mkLCH l c (CIE.clamp (h + (360*(pct 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+ chroma (CIE.unLCH -> ColorCoord(l,c,h)) w =+ CIE.mkLCH l (CIE.clamp (c + (120*(pct w))) 120.0) h ------------------------------------------------------------------------------ -- Utilities@@ -142,7 +143,3 @@ -- | 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
src/Data/Prizm/Color/CIE.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -17,50 +20,31 @@ -- * 'CIELCH' ---------------------------------------------------------------------------- module Data.Prizm.Color.CIE-( module Data.Prizm.Color.CIE.Types+( clamp+, module Data.Prizm.Color.CIE.Types ) where import Control.Applicative import Data.Convertible.Base import Data.Convertible.Utils+import qualified Data.Prizm.Color.CIE.Chroma.Illuminant as Illuminant+import Data.Prizm.Color.CIE.Matrices.XYZ 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.RGB as RGB+import Data.Prizm.Color.CIE.Types as CIE+import qualified Data.Prizm.Color.Constants as Constants+import Data.Prizm.Color.RGB (RGB)+import qualified Data.Prizm.Color.RGB as RGB import Data.Prizm.Color.Transform import Data.Prizm.Types ------------------------------------------------------------------------------ -- Utilities --------------------------------------------------------------------------------- | Reference white, 2° observer, d65 illuminant.------ These values came from Bruce Lindbloom's website: <https://web.archive.org/web/20161110173539/http://www.brucelindbloom.com/index.html?Eqn_ChromAdapt.html Chromatic Adaptation>------ 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] +-- | Clamp a 'Double' with a bottom of at least 0.0.+clamp :: Double -> Double -> Double+clamp i clmp = max (min i clmp) 0.0+ -- | Transform a 'CIE.XYZ' point. -- -- TODO: should provide *much* better documentation on what this is@@ -97,101 +81,121 @@ -- -- 'XYZtoRGB' is the pre-calculated illuminant matrix, it is -- preferable to use 'toRG' as it uses the most "common" one.-toRGBMatrix :: XYZtoRGB -> CIE.XYZ -> RGB-toRGBMatrix (XYZtoRGB m) (CIE.XYZ x y z) =- let t = ZipList ((/100) <$> [x,y,z])+toRGBMatrix :: XYZtoRGB -> CIE.XYZ -> RGB.RGB+toRGBMatrix (Matrix m) (unXYZ -> ColorCoord(x,y,z)) =+ let t = ((/100) <$> ZipList [x,y,z]) -- NB: be sure to clamp before converting to a Word8, -- otherwise we can overflow! [r,g,b] = (fromIntegral . RGB.clamp . transformRGB) <$> ((zipTransform t) <$> m)- in RGB r g b+ in RGB.mkRGB r g b +-- | Convert a 'XYZ' color to the 'LAB' color space using the given+-- reference white illuminant.+--+-- NB: the convertible instance uses the 'd65' reference white+-- illuminant, use this function if you need to use a different+-- reference white.+xyzToLAB :: CIE.XYZ -> Illuminant.RefWhite -> CIE.LAB+xyzToLAB (unXYZ -> ColorCoord xyz) (Illuminant.Tristimulus refWhite) =+ -- TODO: figure out how I can use <$$$> lens version with some+ -- kind of applicative-like thing to do the below...+ let v = (/) <$$$> xyz <***> refWhite+ (tx,ty,tz) = ((transformLAB) <$$$> v)+ l = (116 * ty) - 16+ a = 500 * (tx - ty)+ b = 200 * (ty - tz)+ in CIE.mkLAB l a b++-- | Convert a 'LAB' color to the 'XYZ' color space using the given+-- reference white illuminant.+--+-- NB: the convertible instance uses the 'd65' reference white+-- illuminant, use this function if you need to use a different+-- reference white.+labToXYZ :: CIE.LAB -> Illuminant.RefWhite -> CIE.XYZ+labToXYZ (unLAB -> ColorCoord(l,a,b)) (Illuminant.Tristimulus refWhite) =+ let y = (l + 16) / 116+ x = a / 500 + y+ z = y - b / 200+ (nx,ny,nz) = ((*) <$$$> (transformXYZ <$$$> (x,y,z))) <***> refWhite+ in CIE.mkXYZ nx ny nz+ ------------------------------------------------------------------------------ -- Convertible ------------------------------------------------------------------------------ instance Convertible CIE.LAB CIE.LCH where- -- | Convert a 'CIE.LAB' to a 'CIE.LCH'- safeConvert (CIE.LAB l a b) =+ -- | Convert a 'CIE.LAB' color to a 'CIE.LCH' color+ safeConvert (unLAB -> ColorCoord (l,a,b)) = let h = calcLCHHue (atan2 b a) c = sqrt ((a^(2 :: Int)) + (b^(2 :: Int)))- in Right $ CIE.LCH l c h+ in Right $ CIE.mkLCH l c h 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 $ CIE.XYZ nx ny nz+ -- | Convert a 'CIE.LAB' color to a 'CIE.XYZ' color+ safeConvert lab = Right $ labToXYZ lab Illuminant.d65 instance Convertible CIE.LAB RGB where- -- | Convert a 'CIE.LAB' to a S'RGB'+ -- | Convert a 'CIE.LAB' color to a 256-cubed 'RGB' color safeConvert = convertVia (undefined :: CIE.XYZ) -instance Convertible CIE.LAB Hex where- -- | Convert a 'CIE.LAB' to an S'RGB' hexadecimal color+instance Convertible CIE.LAB HexRGB where+ -- | Convert a 'CIE.LAB' color to a 256-cubed, 'HexRGB' encoded 'RGB' color safeConvert = convertVia (undefined :: RGB) instance Convertible RGB CIE.LAB where- -- | Convert a S'RGB' to a 'CIE.LAB'+ -- | Convert a 256-cubed 'RGB' color to a 'CIE.LAB' color safeConvert = convertVia (undefined :: CIE.XYZ) instance Convertible RGB CIE.LCH where- -- | Convert a S'RGB' to a 'CIE.LCH'+ -- | Convert a 256-cubed 'RGB' color to a 'CIE.LCH' color safeConvert = convertVia (undefined :: CIE.LAB) -instance Convertible Hex CIE.LAB where- -- | Convert an S'RGB' hexadecimal color to a 'CIE.LAB'+instance Convertible HexRGB CIE.LAB where+ -- | Convert a 'HexRGB' encoded 256-cubed 'RGB' color to a 'CIE.LAB' color safeConvert = convertVia (undefined :: RGB) -instance Convertible Hex CIE.LCH where- -- | Convert an S'RGB' hexadecimal color to a 'CIE.LCH'+instance Convertible HexRGB CIE.LCH where+ -- | Convert a 'HexRGB' encoded 256-cubed 'RGB' color to a 'CIE.LCH' color safeConvert = convertVia (undefined :: RGB) instance Convertible CIE.LCH CIE.LAB where- -- | Convert a 'CIE.LCH' to a 'CIE.LAB'- safeConvert (CIE.LCH l c h) =+ -- | Convert a 'CIE.LCH' color to a 'CIE.LAB' color+ safeConvert (unLCH -> ColorCoord (l,c,h)) = let v = h * pi / 180- in Right $ CIE.LAB l ((cos v)*c) ((sin v)*c)+ in Right $ CIE.mkLAB l ((cos v)*c) ((sin v)*c) instance Convertible CIE.LCH RGB where- -- | Convert a 'CIE.LCH' to a S'RGB'+ -- | Convert a 'CIE.LCH' color to a 256-cubed 'RGB' color safeConvert = convertVia (undefined :: CIE.LAB) -instance Convertible CIE.LCH Hex where- -- | Convert a 'CIE.LCH' to a RGB hexadecimal representation+instance Convertible CIE.LCH HexRGB where+ -- | Convert a 'CIE.LCH' color to a 256-cubed, 'HexRGB' encoded 'RGB' color safeConvert = convertVia (undefined :: 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'+ -- | Convert a 'CIE.XYZ' color to a 256-cubed 'RGB' color -- -- This function uses the default d65 illuminant matrix. safeConvert = Right . toRGBMatrix d65SRGB -instance Convertible CIE.XYZ Hex where- -- | Convert a 'CIE.XYZ' to an S'RGB' hexadecimal color+instance Convertible CIE.XYZ HexRGB where+ -- | Convert a 'CIE.XYZ' color to a 256-cubed, 'HexRGB' encoded 'RGB' color safeConvert = convertVia (undefined :: RGB) instance Convertible CIE.XYZ CIE.LCH where- -- | Convert a 'CIE.XYZ' to a 'CIE.LCH' via 'CIE.LAB'+ -- | Convert a 'CIE.XYZ' color to a 'CIE.LCH' color safeConvert = convertVia (undefined :: CIE.LAB) instance Convertible CIE.XYZ CIE.LAB where- -- | Convert an 'CIE.XYZ' to a 'CIE.LAB'+ -- | Convert a 'CIE.XYZ' color to a 'CIE.LAB' color -- -- This function uses the default reference white (2deg observer, -- d65 illuminant).- 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 $ CIE.LAB l a b+ safeConvert xyz = Right $ xyzToLAB xyz Illuminant.d65 -instance Convertible Hex CIE.XYZ where- -- | Convert a hexadecimal S'RGB' color to a 'CIE.XYZ'+instance Convertible HexRGB CIE.XYZ where+ -- | Convert a 'HexRGB' encoded 256-cubed 'RGB' color to the 'CIE.XYZ' color safeConvert = convertVia (undefined :: RGB)
+ src/Data/Prizm/Color/CIE/Chroma/Illuminant.hs view
@@ -0,0 +1,69 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Prizm.Color.CIE.Chroma.Illuminant+-- Copyright : (C) 2017 Parnell Springmeyer+-- License : BSD3+-- Maintainer : Parnell Springmeyer <parnell@digitalmentat.com>+-- Stability : stable+--+-- These values came from Bruce Lindbloom's website: <https://web.archive.org/web/20161110173539/http://www.brucelindbloom.com/index.html?Eqn_ChromAdapt.html Chromatic Adaptation>+--+-- For future reference (also found in the above linked website), here+-- is a list of the reference white illuminant values:+--+-- * X Y Z+-- * @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@+-----------------------------------------------------------------------------+module Data.Prizm.Color.CIE.Chroma.Illuminant+( RefWhite(..)+, a, b, c, d50+, d55, d65, d75+, e, f2, f7, f11+) where++-- | Reference white tristimulus value.+newtype RefWhite = Tristimulus (Double, Double, Double)+ deriving (Eq, Ord, Show)++a :: RefWhite+a = Tristimulus(190.850, 100.000, 35.585)++b :: RefWhite+b = Tristimulus(99.072, 100.000, 85.223)++c :: RefWhite+c = Tristimulus(98.074, 100.000, 118.232)++d50 :: RefWhite+d50 = Tristimulus(96.422, 100.000, 82.521)++d55 :: RefWhite+d55 = Tristimulus(95.682, 100.000, 92.149)++d65 :: RefWhite+d65 = Tristimulus(95.047, 100.000, 108.883)++d75 :: RefWhite+d75 = Tristimulus(94.972, 100.000, 122.638)++e :: RefWhite+e = Tristimulus(100.000, 100.000, 100.000)++f2 :: RefWhite+f2 = Tristimulus(99.186, 100.000, 67.393)++f7 :: RefWhite+f7 = Tristimulus(95.041, 100.000, 108.747)++f11 :: RefWhite+f11 = Tristimulus(100.962, 100.000, 64.350)
+ src/Data/Prizm/Color/CIE/Matrices/RGB.hs view
@@ -0,0 +1,29 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Prizm.Color.CIE.Matrices.RGB+-- Copyright : (C) 2013 Parnell Springmeyer+-- License : BSD3+-- Maintainer : Parnell Springmeyer <parnell@digitalmentat.com>+-- Stability : stable+--+-- Pre-calculated illuminant matrices: <http://www.brucelindbloom.com/index.html?Eqn_RGB_XYZ_Matrix.html RGB to XYZ Matrix>.+-----------------------------------------------------------------------------+module Data.Prizm.Color.CIE.Matrices.RGB where++-- | Working space matrix to convert from sRGB to CIE XYZ.+newtype RGBtoXYZ = Matrix [[Double]]+ deriving (Eq, Ord, Show)++-- TODO: this should probably be a vector of triples.+d65SRGB :: RGBtoXYZ+d65SRGB = Matrix [+ [0.4124564, 0.3575761, 0.1804375],+ [0.2126729, 0.7151522, 0.0721750],+ [0.0193339, 0.1191920, 0.9503041]]++-- TODO: this should probably be a vector of triples.+d65Adobe :: RGBtoXYZ+d65Adobe = Matrix [+ [0.5767309],[0.1855540],[0.1881852],+ [0.2973769],[0.6273491],[0.0752741],+ [0.0270343],[0.0706872],[0.9911085]]
+ src/Data/Prizm/Color/CIE/Matrices/XYZ.hs view
@@ -0,0 +1,29 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Prizm.Color.CIE.Matrices.XYZ+-- Copyright : (C) 2013 Parnell Springmeyer+-- License : BSD3+-- Maintainer : Parnell Springmeyer <parnell@digitalmentat.com>+-- Stability : stable+--+-- Pre-calculated illuminant matrices: <http://www.brucelindbloom.com/index.html?Eqn_RGB_XYZ_Matrix.html RGB to XYZ Matrix>.+-----------------------------------------------------------------------------+module Data.Prizm.Color.CIE.Matrices.XYZ where++-- | Working space matrix to convert from CIE XYZ to sRGB.+newtype XYZtoRGB = Matrix [[Double]]+ deriving (Eq, Ord, Show)+++d65SRGB :: XYZtoRGB+d65SRGB = Matrix [+ [3.2404542, (-1.5371385), (-0.4985314)],+ [(-0.9692660), 1.8760108, 0.0415560],+ [0.0556434, (-0.2040259), 1.0572252]]++-- TODO: this should probably be a vector of triples.+d65Adobe :: XYZtoRGB+d65Adobe = Matrix [+ [2.0413690],[(-0.5649464)],[(-0.3446944)],+ [(-0.9692660)],[1.8760108],[0.0415560],+ [0.0134474],[(-0.1183897)],[1.0154096]]
src/Data/Prizm/Color/CIE/Types.hs view
@@ -11,27 +11,37 @@ ----------------------------------------------------------------------------- module Data.Prizm.Color.CIE.Types where -import Data.MonoTraversable+import Data.Prizm.Types -- | A color in the @CIE XYZ@ color space.-data XYZ = XYZ !Double !Double !Double+newtype XYZ = XYZ { unXYZ :: ColorCoord Double } deriving (Eq, Ord, Show) -- | A color in the @CIE L*a*b*@ color space.-data LAB = LAB !Double !Double !Double+newtype LAB = LAB { unLAB :: ColorCoord Double } deriving (Eq, Ord, Show) -- | A color in the @CIE L*C*h(uv)@ color space.-data LCH = LCH !Double !Double !Double+newtype LCH = LCH { unLCH :: ColorCoord Double } deriving (Eq, Ord, Show) -type instance Element XYZ = Double-type instance Element LCH = Double-type instance Element LAB = Double+-- | Produce a CIE XYZ color.+mkXYZ :: Double -- ^ @X@ color point+ -> Double -- ^ @Y@ color point+ -> Double -- ^ @Z@ color point+ -> XYZ+mkXYZ x y z = XYZ (ColorCoord (x,y,z)) -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)+-- | Produce a CIE LAB color.+mkLAB :: Double -- ^ @L@ color point+ -> Double -- ^ @*a@ color point+ -> Double -- ^ @*b@ color point+ -> LAB+mkLAB l a b = LAB (ColorCoord (l,a,b))++-- | Produce a CIE LCH color.+mkLCH :: Double -- ^ @L@ color point+ -> Double -- ^ @*c@ color point+ -> Double -- ^ @*h@ color point+ -> LCH+mkLCH l c h = LCH (ColorCoord (l,c,h))
− src/Data/Prizm/Color/Matrices/RGB.hs
@@ -1,27 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Prizm.Color.Matrices.RGB--- Copyright : (C) 2013 Parnell Springmeyer--- License : BSD3--- Maintainer : Parnell Springmeyer <parnell@digitalmentat.com>--- Stability : stable------ Pre-calculated illuminant matrices: <http://www.brucelindbloom.com/index.html?Eqn_RGB_XYZ_Matrix.html RGB to XYZ Matrix>.-------------------------------------------------------------------------------module Data.Prizm.Color.Matrices.RGB where--import Data.Prizm.Types---- TODO: this should probably be a vector of triples.-d65SRGB :: RGBtoXYZ-d65SRGB = RGBtoXYZ [- [0.4124564, 0.3575761, 0.1804375],- [0.2126729, 0.7151522, 0.0721750],- [0.0193339, 0.1191920, 0.9503041]]---- TODO: this should probably be a vector of triples.-d65Adobe :: RGBtoXYZ-d65Adobe = RGBtoXYZ [- [0.5767309],[0.1855540],[0.1881852],- [0.2973769],[0.6273491],[0.0752741],- [0.0270343],[0.0706872],[0.9911085]]
− src/Data/Prizm/Color/Matrices/XYZ.hs
@@ -1,27 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Prizm.Color.Matrices.XYZ--- Copyright : (C) 2013 Parnell Springmeyer--- License : BSD3--- Maintainer : Parnell Springmeyer <parnell@digitalmentat.com>--- Stability : stable------ Pre-calculated illuminant matrices: <http://www.brucelindbloom.com/index.html?Eqn_RGB_XYZ_Matrix.html RGB to XYZ Matrix>.-------------------------------------------------------------------------------module Data.Prizm.Color.Matrices.XYZ where--import Data.Prizm.Types---- TODO: this should probably be a vector of triples.-d65SRGB :: XYZtoRGB-d65SRGB = XYZtoRGB [- [3.2404542, (-1.5371385), (-0.4985314)],- [(-0.9692660), 1.8760108, 0.0415560],- [0.0556434, (-0.2040259), 1.0572252]]---- TODO: this should probably be a vector of triples.-d65Adobe :: XYZtoRGB-d65Adobe = XYZtoRGB [- [2.0413690],[(-0.5649464)],[(-0.3446944)],- [(-0.9692660)],[1.8760108],[0.0415560],- [0.0134474],[(-0.1183897)],[1.0154096]]
src/Data/Prizm/Color/RGB.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -14,22 +15,22 @@ -- conversion between 'RGB' and 'CIEXYZ'. ---------------------------------------------------------------------------- module Data.Prizm.Color.RGB-( clamp-, module Data.Prizm.Color.RGB.Types+( module Data.Prizm.Color.RGB.Types ) where import Control.Applicative+import Data.Bifunctor as Bifunctor import Data.Convertible.Base+import qualified Data.Foldable as Foldable import Data.Monoid-import Data.Prizm.Color.CIE.Types as CIE-import Data.Prizm.Color.Matrices.RGB+import Data.Prizm.Color.CIE.Matrices.RGB+import Data.Prizm.Color.CIE.Types as CIE 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)+import qualified Data.Text as Text+import qualified Data.Text.Read as Text.Read+import Numeric (showHex) ------------------------------------------------------------------------------ -- Utilities@@ -41,40 +42,40 @@ 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+-- | Encode a 256-cubed 'RGB' color into a 'HexRGB', e.g. @#00aaff@+encodeHex :: RGB -> HexRGB+encodeHex (RGB rgb) = HexRGB (Text.pack $ "#" <> (Foldable.foldMap encode rgb))+ where+ encode x | x <= 0xf = "0"<>(showHex x "")+ | otherwise = showHex x "" --- All credit for the below three functions go to the HSColour module.+-- | Decode a 'HexRGB' encoded RGB color (e.g: #D60CD3) into 256-cubed+-- 'RGB'.+decodeHex :: HexRGB -> Either String RGB+decodeHex (HexRGB orig@(Text.uncons -> cell)) =+ case cell of+ Just ('#', rest) ->+ case Text.unpack rest of+ [a, b, c, d, e, f, _g, _h]+ -> mkRGB <$> hex a b <*> hex c d <*> hex e f --- | 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+ [a, b, c, d, e, f]+ -> mkRGB <$> hex a b <*> hex c d <*> hex e f --- | 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+ [a, b, c, _d]+ -> mkRGB <$> hex a a <*> hex b b <*> hex c c + [a, b, c]+ -> mkRGB <$> hex a a <*> hex b b <*> hex c c+ _ -> can'tDecode+ _ -> can'tDecode+ 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"+ hex :: Char -> Char -> Either String Int+ hex a b = Bifunctor.second fst $ Text.Read.hexadecimal (Text.singleton a <> Text.singleton b) + can'tDecode = Left $ "cannot decode "++(Text.unpack orig)+ ------------------------------------------------------------------------------ -- Convertible ------------------------------------------------------------------------------@@ -83,18 +84,26 @@ -- @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 RGB HexRGB where+ -- | Convert a 256-cubed 'RGB' color to a hexadecimal encoding.+ safeConvert = Right . encodeHex -instance Convertible Hex RGB where- -- | Convert a hexadecimal value to an S'RGB'.- safeConvert = Right . parse . fromString+instance Convertible HexRGB RGB where+ -- | Convert a hexadecimal value to an 'RGB'.+ safeConvert v = Bifunctor.first convertibleError $ decodeHex v+ where+ convertibleError msg =+ ConvertError+ { convSourceValue = show v+ , convSourceType = "HexRGB"+ , convDestType = "RGB"+ , convErrorMessage = msg+ } -- | 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) =+toXYZMatrix (Matrix m) (unRGB -> ColorCoord(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+ in CIE.mkXYZ x y z
src/Data/Prizm/Color/RGB/Types.hs view
@@ -10,15 +10,23 @@ ----------------------------------------------------------------------------- module Data.Prizm.Color.RGB.Types where -import Data.MonoTraversable+import Data.Prizm.Types import Data.Word --- | A color in the @sRGB@ color space.-data RGB = RGB !Word8 !Word8 !Word8- deriving (Eq, Ord, Show)+-- | Clamp a 'Word8' with an upper-bound of 255 and a lower-bound of+-- 0.+clamp :: Integral a => a -> a+clamp i = max (min i 255) 0 --- | Monomorphic functor instances for the color spaces.-type instance Element RGB = Word8+-- | A color in the 256-cubed @RGB@ color space.+newtype RGB = RGB {unRGB :: ColorCoord Word8 }+ deriving (Eq, Ord, Show) -instance MonoFunctor RGB where- omap f (RGB r g b) = RGB (f r) (f g) (f b)+-- | Produce a 256-cubed 'RGB' color.+--+-- NB: this function clamps each argument to the 0-255 range.+mkRGB :: Int -- ^ Red color channel+ -> Int -- ^ Green color channel+ -> Int -- ^ Blue color channel+ -> RGB+mkRGB r g b = RGB ((fromIntegral . clamp) <$> ColorCoord (r,g,b))
src/Data/Prizm/Color/Transform.hs view
@@ -11,13 +11,22 @@ import Control.Applicative --- | Round a number to the Nth place.-roundN :: Integer -> Double -> Double+-- | Round a number to the Nth decimal place.+roundN :: Integer -- ^ Nth place to round a number to+ -> Double -- ^ Number to round+ -> Double roundN n num = (fromInteger $ round $ num * (10^n)) / (10.0^^n) --- | Truncate a number to the Nth place.-truncateN :: Integer -> Double -> Double-truncateN = roundN--zipTransform :: ZipList Double -> [Double] -> Double-zipTransform tv m = sum $ getZipList $ (*) <$> ZipList m <*> tv+-- | Transform a triplet of values from a working space matrix,+-- sequentially multiplying each value against a 'ZipList' of input+-- transformation values and taking the sum.+--+-- I'm sure there's a math-y word for what this is doing (affine+-- transformation?).+--+-- TODO: use a triple instead of a list! It is possible to goof up by+-- providing a list of elements greater than three.+zipTransform :: ZipList Double -- ^ ZipList of values to transform matrix triplet+ -> [Double] -- ^ Working space triplet+ -> Double -- ^ Sum of the sequentially applied transformation+zipTransform tv matrix = sum $ getZipList $ (*) <$> ZipList matrix <*> tv
src/Data/Prizm/Types.hs view
@@ -10,32 +10,58 @@ -- Stability : stable ----------------------------------------------------------------------------- module Data.Prizm.Types-(--- * Generic Utility Types- RGBtoXYZ(..)-, XYZtoRGB(..)-, Hex+( HexRGB(..) , Percent--- * CIE Color Space Types-, module Data.Prizm.Color.CIE.Types--- * RGB Color Space Types-, module Data.Prizm.Color.RGB.Types+, ColorCoord(..)+, (<$$$>)+, (<***>) ) where -import Data.Prizm.Color.CIE.Types-import Data.Prizm.Color.RGB.Types+import Data.Monoid+import Data.Text --- | Working space matrix to convert from sRGB to CIE XYZ.-newtype RGBtoXYZ = RGBtoXYZ [[Double]]- deriving (Eq, Ord, Show)+-- | Map a function over each element of a triple..+(<$$$>) :: (a -> b) -> (a,a,a) -> (b,b,b)+(<$$$>) f (a1,a2,a3) = (f a1, f a2, f a3) --- | Working space matrix to convert from CIE XYZ to sRGB.-newtype XYZtoRGB = XYZtoRGB [[Double]]- deriving (Eq, Ord, Show)+-- | Sequentially apply a triple to another triple, like Applicative's+-- sequential application but specialized to triples.+(<***>) :: ((a -> b), (a -> b), (a -> b)) -> (a,a,a) -> (b,b,b)+(<***>) (fa1, fa2, fa3) (b1,b2,b3) = (fa1 b1, fa2 b2, fa3 b3) --- | Hexadecimal encoded color code with an octothorpe prefix; e.g:+-- | A generic representation of a color triple; this may be *any*+-- color space so you should not construct colors with 'ColorCoord'+-- and instead you should use specialized color constructors from the+-- 'Data.Prizm.Color.RGB' module or 'Data.Prizm.Color.CIE' module.+newtype ColorCoord a = ColorCoord (a, a, a)+ deriving (Show, Eq, Ord, Read)++-- | Hexadecimal encoded RGB color with an octothorpe prefix; e.g: -- @#AB9D92@.-type Hex = String+--+-- Please see 'RGB.decodeHex'.+newtype HexRGB = HexRGB { unHexRGB :: Text }+ deriving (Show, Eq, Ord, Read) -- | A percent value ranging from -100 to 100; e.g: -82%, 80%, 10%. type Percent = Integer++instance Functor ColorCoord where+ fmap f (ColorCoord (a,b,c)) = ColorCoord (f a, f b, f c)++instance Applicative ColorCoord where+ pure c = ColorCoord (c,c,c)+ (ColorCoord (fa,fb,fc)) <*> (ColorCoord (a,b,c)) = ColorCoord (fa a, fb b, fc c)++instance Foldable ColorCoord where+ foldMap f (ColorCoord (a,b,c)) = f a <> f b <> f c++instance Traversable ColorCoord where+ traverse f (ColorCoord (a,b,c)) = ColorCoord <$> ((,,) <$> f a <*> f b <*> f c)++instance Monad ColorCoord where+ ColorCoord (a,b,c) >>= f = ColorCoord (a',b',c')+ where+ ColorCoord(a',_,_) = f a+ ColorCoord(_,b',_) = f b+ ColorCoord(_,_,c') = f c
tests/HUnit/Blending.hs view
@@ -12,22 +12,22 @@ 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)+ [ testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 0%" $ blendPinkGreen 0 (mkRGB 255 0 255)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 10%" $ blendPinkGreen 10 (mkRGB 255 0 210)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 20%" $ blendPinkGreen 20 (mkRGB 255 0 163)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 30%" $ blendPinkGreen 30 (mkRGB 255 0 115)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 40%" $ blendPinkGreen 40 (mkRGB 255 51 67)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 50%" $ blendPinkGreen 50 (mkRGB 255 111 0)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 60%" $ blendPinkGreen 60 (mkRGB 255 152 0)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 70%" $ blendPinkGreen 70 (mkRGB 255 186 0)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 80%" $ blendPinkGreen 80 (mkRGB 222 213 0)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 90%" $ blendPinkGreen 90 (mkRGB 172 236 0)+ , testCase "Blend #ff00ff (pink) with #66ff00 (green) @ 100%" $ blendPinkGreen 100 (mkRGB 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+ let pink :: CIE.LCH = convert $ mkRGB 255 0 255+ green :: CIE.LCH = convert $ mkRGB 102 255 0 blended :: RGB = convert $ interpolate pct (pink,green) in blended @?= expected
tests/QC/CIE.hs view
@@ -6,7 +6,6 @@ import Control.Monad (liftM3) import Data.Convertible-import Data.MonoTraversable import Data.Prizm.Color import Data.Prizm.Color.CIE as CIE import Data.Prizm.Color.Transform@@ -15,30 +14,30 @@ import Test.QuickCheck instance Arbitrary CIE.XYZ where- arbitrary = liftM3 CIE.XYZ (choose (0, 95.047)) (choose (0, 100.000)) (choose (0, 108.883))+ arbitrary = liftM3 CIE.mkXYZ (choose (0, 95.047)) (choose (0, 100.000)) (choose (0, 108.883)) instance Arbitrary CIE.LAB where- arbitrary = liftM3 CIE.LAB (choose (0, 100)) (choose ((-129), 129)) (choose ((-129), 129))+ arbitrary = liftM3 CIE.mkLAB (choose (0, 100)) (choose ((-129), 129)) (choose ((-129), 129)) rN :: Double -> Double rN = roundN 11 xyz2LAB :: CIE.XYZ -> Bool-xyz2LAB ((omap rN ) -> genVal) = genVal == xyz+xyz2LAB (CIE.XYZ . (fmap rN) . unXYZ -> genVal) = genVal == xyz where- ((omap rN) -> xyz) =+ (CIE.XYZ . (fmap rN) . unXYZ -> xyz) = convert ((convert genVal) :: CIE.LAB) lab2XYZ :: CIE.LAB -> Bool-lab2XYZ ((omap rN ) -> genVal) = genVal == lab+lab2XYZ (CIE.LAB . (fmap rN) . unLAB -> genVal) = genVal == lab where- ((omap rN) -> lab) =+ (CIE.LAB . (fmap rN) . unLAB -> lab) = convert ((convert genVal) :: CIE.XYZ) lab2LCH :: CIE.LAB -> Bool-lab2LCH ((omap rN ) -> genVal) = genVal == lch+lab2LCH (CIE.LAB . (fmap rN) . unLAB -> genVal) = genVal == lab where- ((omap rN) -> lch) =+ (CIE.LAB . (fmap rN) . unLAB -> lab) = convert ((convert genVal) :: CIE.LCH) tests :: [Test]
tests/QC/RGB.hs view
@@ -5,14 +5,14 @@ import Control.Monad (liftM3) import Data.Convertible-import Data.Prizm.Color (Hex, RGB (..))+import Data.Prizm.Color 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)+ arbitrary = liftM3 mkRGB (choose rgbRange) (choose rgbRange) (choose rgbRange) where rgbRange = (0, 255) @@ -24,10 +24,10 @@ rgb2HEX :: RGB -> Bool rgb2HEX gVal = gVal == iso where- iso = convert ((convert gVal) :: Hex)+ iso = convert ((convert gVal) :: HexRGB) tests :: [Test] tests =- [ QuickCheck.testProperty "RGB <-> CIE XYZ" rgb2XYZ- , QuickCheck.testProperty "HEX <-> RGB " rgb2HEX+ [ QuickCheck.testProperty "RGB <-> CIE XYZ" rgb2XYZ+ , QuickCheck.testProperty "HexRGB <-> RGB " rgb2HEX ]