colour 2.0.0 → 2.1.0

raw patch · 14 files changed

+494/−176 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Colour.hs +68/−0
• Data/Colour/CIE.hs +133/−0
• Data/Colour/CIE/Chromaticity.hs +29/−10
• Data/Colour/CIE/Illuminant.hs +20/−20
• Data/Colour/Chan.hs +1/−1
• Data/Colour/Internal.hs +9/−20
• Data/Colour/Names.hs +0/−1
• Data/Colour/RGB.hs +32/−9
• Data/Colour/RGBSpace.hs +109/−10
• Data/Colour/SRGB.hs +16/−8
• Data/Colour/SRGB/Linear.hs +17/−4
• README +5/−6
• Tests.hs +51/−84
• colour.cabal +4/−3

@@ -25,6 +25,25 @@ -- The most common way of creating colours is either by name -- (see "Data.Colour.Names") or by giving an sRGB triple  -- (see "Data.Colour.SRGB").+--+-- Methods of specifying Colours can be found in +--+-- - "Data.Colour.SRGB"+--+-- - "Data.Colour.SRGB.Linear"+--+-- - "Data.Colour.CIE"+--+-- Colours can be specified in a generic 'Data.Colour.RGBSpace.RGBSpace'+-- by using+--+-- - "Data.Colour.RGBSpace"+++--TODO+-- - "Data.Colour.HDTV"+--+-- - "Data.Colour.SDTV" module Data.Colour  ( -- *Colour type   Colour@@ -45,4 +64,53 @@  ) where +import Data.Char import Data.Colour.Internal+import qualified Data.Colour.SRGB.Linear+import Data.Colour.CIE.Chromaticity (app_prec, infix_prec)++instance (Fractional a) => Show (Colour a) where+  showsPrec d c = showParen (d > app_prec) showStr+   where+    showStr = showString linearConstructorQualifiedName+            . showString " " . (showsPrec (app_prec+1) r)+            . showString " " . (showsPrec (app_prec+1) g)+            . showString " " . (showsPrec (app_prec+1) b)+    Data.Colour.SRGB.Linear.RGB r g b = Data.Colour.SRGB.Linear.toRGB c++instance (Fractional a, Read a) => Read (Colour a) where+  readsPrec d r = readParen (d > app_prec)+                  (\r -> [(Data.Colour.SRGB.Linear.rgb r0 g0 b0,t)+                         |(name,s) <- mylex r+                         ,name `elem` [linearConstructorName+                                      ,linearConstructorQualifiedName]+                         ,(r0,s0) <- readsPrec (app_prec+1) s+                         ,(g0,s1) <- readsPrec (app_prec+1) s0+                         ,(b0,t)  <- readsPrec (app_prec+1) s1]) r+   where+    mylex = return +          . span (\c -> isAlphaNum c || c `elem` "._'")+          . dropWhile isSpace++linearConstructorQualifiedName = "Data.Colour.SRGB.Linear.rgb"+linearConstructorName = "rgb"++instance (Fractional a) => Show (AlphaColour a) where+  showsPrec d ac | a == 0 = showString "transparent"+                 | otherwise = showParen (d > infix_prec) showStr+   where+    showStr = showsPrec (infix_prec+1) c+            . showString " `withOpacity` "+            . showsPrec (infix_prec+1) a+    a = alphaChannel ac+    c = colourChannel ac++instance (Fractional a, Read a) => Read (AlphaColour a) where+  readsPrec d r = [(transparent,s)|("transparent",s) <- lex r]+               ++ readParen (d > infix_prec)+                  (\r -> [(c `withOpacity` o,s)+                         |(c,r0) <- readsPrec (infix_prec+1) r+                         ,("`",r1) <- lex r0+                         ,("withOpacity",r2) <- lex r1+                         ,("`",r3) <- lex r2+                         ,(o,s)  <- readsPrec (infix_prec+1) r3]) r

@@ -0,0 +1,133 @@+{-+Copyright (c) 2008+Russell O'Connor++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.+-}+-- |Colour operations defined by the International Commission on +-- Illumination (CIE).+module Data.Colour.CIE+ (Colour+ ,cieXYZ, toCIEXYZ, luminance++ ,Chromaticity+ ,mkChromaticity, chromaCoords+ ,chromaX, chromaY, chromaZ+ ,chromaConvert+ ,chromaColour++ --,lightness, cieLab, cieLuv+ )+where++import Data.List+import Data.Colour+import Data.Colour.RGB+import Data.Colour.SRGB.Linear+import Data.Colour.CIE.Chromaticity+import Data.Colour.Matrix++-- |Construct a 'Colour' from XYZ coordinates for the 2&#176; standard+-- (colourimetric) observer.+cieXYZ :: (Fractional a) => a -> a -> a -> Colour a+cieXYZ x y z = rgb r g b+ where+  [r,g,b] = mult matrix [x,y,z]+  matrix = map (map fromRational) xyz2rgb709++-- |Return the XYZ colour coordinates for the 2&#176; standard+-- (colourimetric) observer.+toCIEXYZ :: (Fractional a) => Colour a -> (a,a,a)+toCIEXYZ c = (x,y,z)+ where+  RGB r g b = toRGB c+  [x,y,z] = mult matrix [r,g,b]+  matrix = map (map fromRational) rgb7092xyz++{- CIE luminance -}+-- |Returns the Y colour coordinate (luminance) for the 2&#176; standard+-- (colourimetric) observer.+luminance :: (Fractional a) => Colour a -> a+luminance c = y+ where+  (x,y,z) = toCIEXYZ c++instance AffineSpace Chromaticity where+ affineCombo l z =+   foldl1' chromaAdd [chromaScale w a | (w,a) <- (1-total,z):l]+  where+   total = sum $ map fst l+   (Chroma x0 y0) `chromaAdd` (Chroma x1 y1) = Chroma (x0+x1) (y0+y1)+   s `chromaScale` (Chroma x y) = Chroma (s*x) (s*y)++-- |Constructs a colour from the given 'Chromaticity' and 'luminance'.+chromaColour :: (Fractional a) =>+                Chromaticity a+             -> a              -- ^ 'luminance'+             -> Colour a+chromaColour ch y = cieXYZ (s*ch_x) y (s*ch_z)+ where+  (ch_x, ch_y, ch_z) = chromaCoords ch+  s = y/ch_y++-- |Returns the lightness of a colour, which is a perceptually uniform+-- measure.+lightness :: (Ord a, Floating a) => Colour a -> a+lightness c | (6/29)^3 < y = 116*y**(1/3) - 16+            | otherwise = (29/3)^3*y+ where+  y = luminance c++-- |Returns the CIELAB coordinates of a colour, which is a+-- perceptually uniform colour space.+-- If you don't know what white point to use, use+-- 'Data.Colour.CIE.Illuminant.d65'.+cieLab :: (Ord a, Floating a) => Chromaticity a -- ^White point+                              -> Colour a -> (a,a,a)+cieLab white_ch c = (lightness c, a, b)+ where+  white = chromaColour white_ch 1.0+  (x,y,z) = toCIEXYZ c+  (xn,yn,zn) = toCIEXYZ white+  a = 500*((x/xn)**(1/3) - (y/yn)**(1/3))+  b = 200*((y/yn)**(1/3) - (z/zn)**(1/3))++-- |Returns the CIELUV coordinates of a colour, which is a+-- perceptually uniform colour space.+-- If you don't know what white point to use, use+-- 'Data.Colour.CIE.Illuminant.d65'.+cieLuv :: (Ord a, Floating a) => Chromaticity a -- ^White point+                              -> Colour a -> (a,a,a)+cieLuv white_ch c = (l, 13*l*(u'-un'), 13*l*(v'-vn'))+ where+  white = chromaColour white_ch 1.0+  (u', v') = u'v' c+  (un', vn') = u'v' white+  l = lightness c+--------------------------------------------------------------------------+{- not for export -}+u'v' :: (Ord a, Floating a) => Colour a -> (a,a)+u'v' c = (4*x/(x+15*y+3*z), 9*y/(x+15*y+3*z))+ where+  (x,y,z) = toCIEXYZ c++rgb7092xyz = (rgb2xyz sRGBGamut)++xyz2rgb709 = inverse rgb7092xyz+

@@ -24,27 +24,46 @@  data Chromaticity a = Chroma !a !a deriving (Eq) +-- |Constructs 'Chromaticity' from the CIE little /x/, little /y/+-- coordinates for the 2&#176; standard (colourimetric) observer.+mkChromaticity :: (Fractional a) => a -> a -> Chromaticity a+mkChromaticity = Chroma+ -- |Returns the CIE little /x/, little /y/, little /z/ coordinates -- for the 2&#176; standard (colourimetric) observer.-chroma_coords :: (Fractional a) => Chromaticity a -> (a, a, a)-chroma_coords (Chroma x y) = (x, y, 1 - x - y)+chromaCoords :: (Fractional a) => Chromaticity a -> (a, a, a)+chromaCoords (Chroma x y) = (x, y, 1 - x - y) --- |Constructs 'Chromaticity' from the CIE little /x/, little /y/--- coordinates for the 2&#176; standard (colourimetric) observer.-cieChroma :: (Fractional a) => a -> a -> Chromaticity a-cieChroma = Chroma+-- |Returns the CIE little /x/ coordinate+-- for the 2&#176; standard (colourimetric) observer.+chromaX :: (Fractional a) => Chromaticity a -> a+chromaX (Chroma x _y) = x +-- |Returns the CIE little /y/ coordinate+-- for the 2&#176; standard (colourimetric) observer.+chromaY :: (Fractional a) => Chromaticity a -> a+chromaY (Chroma _x y) = y++-- |Returns the CIE little /z/ coordinate+-- for the 2&#176; standard (colourimetric) observer.+chromaZ :: (Fractional a) => Chromaticity a -> a+chromaZ (Chroma x y) = 1 - x - y++-- |Change the type used to represent the chromaticity coordinates.+chromaConvert :: (Fractional b, Real a) => Chromaticity a -> Chromaticity b+chromaConvert (Chroma x y) = Chroma (realToFrac x) (realToFrac y)+ instance (Fractional a) => Show (Chromaticity a) where   showsPrec d c = showParen (d > app_prec) showStr    where-    showStr = showString "cieChroma " . (showsPrec (app_prec+1) x)+    showStr = showString "mkChromaticity " . (showsPrec (app_prec+1) x)             . showString " "          . (showsPrec (app_prec+1) y)-    (x,y,z) = chroma_coords c+    (x,y,z) = chromaCoords c  instance (Fractional a, Read a) => Read (Chromaticity a) where   readsPrec d r = readParen (d > app_prec)-                  (\r -> [(cieChroma x y,t)-                         |("cieChroma",s) <- lex r+                  (\r -> [(mkChromaticity x y,t)+                         |("mkChromaticity",s) <- lex r                          ,(x,s0) <- readsPrec (app_prec+1) s                          ,(y,t) <- readsPrec (app_prec+1) s0]) r 

@@ -28,80 +28,80 @@  -- |Incandescent \/ Tungsten a   :: (Fractional a) => Chromaticity a-a   = cieChroma 0.44757 0.40745 +a   = mkChromaticity 0.44757 0.40745   -- |{obsolete} Direct sunlight at noon b   :: (Fractional a) => Chromaticity a-b   = cieChroma 0.34842 0.35161+b   = mkChromaticity 0.34842 0.35161  -- |{obsolete} Average \/ North sky Daylight c   :: (Fractional a) => Chromaticity a-c   = cieChroma 0.31006 0.31616+c   = mkChromaticity 0.31006 0.31616  -- |Horizon Light. ICC profile PCS d50 :: (Fractional a) => Chromaticity a-d50 = cieChroma 0.34567 0.35850+d50 = mkChromaticity 0.34567 0.35850  -- |Mid-morning \/ Mid-afternoon Daylight d55 :: (Fractional a) => Chromaticity a-d55 = cieChroma 0.33242 0.34743+d55 = mkChromaticity 0.33242 0.34743  -- |Noon Daylight: Television, sRGB color space d65 :: (Fractional a) => Chromaticity a-d65 = cieChroma 0.31271 0.32902+d65 = mkChromaticity 0.31271 0.32902  -- |North sky Daylight d75 :: (Fractional a) => Chromaticity a-d75 = cieChroma 0.29902 0.31485+d75 = mkChromaticity 0.29902 0.31485  -- |Equal energy e   :: (Fractional a) => Chromaticity a-e   = cieChroma (1/3)   (1/3)+e   = mkChromaticity (1/3)   (1/3)  -- |Daylight Fluorescent f1  :: (Fractional a) => Chromaticity a-f1  = cieChroma 0.31310 0.33727+f1  = mkChromaticity 0.31310 0.33727  -- |Cool White Fluorescent f2  :: (Fractional a) => Chromaticity a-f2  = cieChroma 0.37208 0.37529+f2  = mkChromaticity 0.37208 0.37529  -- |White Fluorescent f3  :: (Fractional a) => Chromaticity a-f3  = cieChroma 0.40910 0.39430+f3  = mkChromaticity 0.40910 0.39430  -- |Warm White Fluorescent f4  :: (Fractional a) => Chromaticity a-f4  = cieChroma 0.44018 0.40329+f4  = mkChromaticity 0.44018 0.40329  -- |Daylight Fluorescent f5  :: (Fractional a) => Chromaticity a-f5  = cieChroma 0.31379 0.34531+f5  = mkChromaticity 0.31379 0.34531  -- |Lite White Fluorescent f6  :: (Fractional a) => Chromaticity a-f6  = cieChroma 0.37790 0.38835+f6  = mkChromaticity 0.37790 0.38835  -- |D65 simulator, Daylight simulator f7  :: (Fractional a) => Chromaticity a-f7  = cieChroma 0.31292 0.32933+f7  = mkChromaticity 0.31292 0.32933  -- |D50 simulator, Sylvania F40 Design 50 f8  :: (Fractional a) => Chromaticity a-f8  = cieChroma 0.34588 0.35875+f8  = mkChromaticity 0.34588 0.35875  -- |Cool White Deluxe Fluorescent f9  :: (Fractional a) => Chromaticity a-f9  = cieChroma 0.37417 0.37281+f9  = mkChromaticity 0.37417 0.37281  -- |Philips TL85, Ultralume 50 f10 :: (Fractional a) => Chromaticity a-f10 = cieChroma 0.34609 0.35986+f10 = mkChromaticity 0.34609 0.35986  -- |Philips TL84, Ultralume 40 f11 :: (Fractional a) => Chromaticity a-f11 = cieChroma 0.38052 0.37713+f11 = mkChromaticity 0.38052 0.37713  -- |Philips TL83, Ultralume 30 f12 :: (Fractional a) => Chromaticity a-f12 = cieChroma 0.43695 0.40441+f12 = mkChromaticity 0.43695 0.40441

@@ -24,7 +24,7 @@ {- For internal use only:    Not to be exported from the package -} -import qualified Data.List+import qualified Data.List (sum)  newtype Chan p a = Chan a deriving (Eq) 

@@ -23,10 +23,6 @@ module Data.Colour.Internal where  import Data.List-import qualified Data.Colour.RGB-import Data.Colour.RGB (RGBSpace(..))-import Data.Colour.CIE.Chromaticity-import Data.Colour.CIE.Illuminant import qualified Data.Colour.Chan as Chan import Data.Colour.Chan (Chan(Chan)) import Data.Monoid@@ -47,16 +43,6 @@ data Colour a = RGB !(Chan Red a) !(Chan Green a) !(Chan Blue a)                  deriving (Eq) --- |Constructs a 'Colour' from RGB values using the /linear/ RGB colour--- space specified in Rec.709.-rgb709 :: (Fractional a) => a -> a -> a -> Colour a-rgb709 r g b = RGB (Chan r) (Chan g) (Chan b)---- |Return RGB values using the /linear/ RGB colour space specified in--- Rec.709.-toRGB709 :: (Fractional a) => Colour a -> Data.Colour.RGB.RGB a-toRGB709 (RGB (Chan r) (Chan g) (Chan b)) = Data.Colour.RGB.RGB r g b- -- |Change the type used to represent the colour coordinates. colourConvert :: (Fractional b, Real a) => Colour a -> Colour b colourConvert (RGB r g b) =@@ -206,12 +192,15 @@ alphaChannel :: AlphaColour a -> a alphaChannel (RGBA _ (Chan a)) = a -rgb709Space :: Fractional a => RGBSpace a-rgb709Space = RGBSpace (Data.Colour.RGB.RGB-                        (cieChroma 0.64 0.33)-                        (cieChroma 0.30 0.60)-                        (cieChroma 0.15 0.06))-                       d65+-- |Returns the colour of an 'AlphaColour'.+-- @colourChannel transparent@ is undefined and may result in @nan@ or an+-- error.+-- Its use is discouraged.+-- If you are desperate, use+--+-- >darken (recip (alphaChannel c)) (c `over` black)+colourChannel :: (Fractional a) => AlphaColour a -> Colour a+colourChannel (RGBA c (Chan a)) = darken (recip a) c  -------------------------------------------------------------------------- -- not for export

@@ -32,7 +32,6 @@  import Prelude hiding (tan) import Data.Colour.SRGB-import Data.Colour  readColourName :: (Monad m, Ord a, Floating a) => String -> m (Colour a) readColourName "aliceblue" = return aliceblue

@@ -43,11 +43,35 @@ curryRGB :: (RGB a -> b) -> a -> a -> a -> b curryRGB f r g b = f (RGB r g b) --- Should a always be Rational?-data RGBSpace a = RGBSpace {primaries :: !(RGB (Chromaticity a))-                           ,whitePoint   :: !(Chromaticity a)-                           } deriving (Eq, Read, Show)+-- |An 'RGBGamut' is a 3-D colour &#8220;cube&#8221; that contains all the+-- colours that can be displayed by a RGB device.+-- The &#8220;cube&#8221; is normalized so that white has+-- 'Data.Colour.CIE.luminance' 1.+data RGBGamut = RGBGamut {primaries :: !(RGB (Chromaticity Rational))+                         ,whitePoint :: !(Chromaticity Rational)+                         } deriving (Eq) +instance Show RGBGamut where+  showsPrec d gamut = showParen (d > app_prec) showStr+   where+    showStr = showString "mkRGBGamut"+            . showString " " . (showsPrec (app_prec+1) (primaries gamut))+            . showString " " . (showsPrec (app_prec+1) (whitePoint gamut))++instance Read RGBGamut where+  readsPrec d r = readParen (d > app_prec)+                  (\r -> [(mkRGBGamut p w,t)+                         |("mkRGBGamut",s) <- lex r+                         ,(p,s0) <- readsPrec (app_prec+1) s+                         ,(w,t)  <- readsPrec (app_prec+1) s0]) r++-- |An RGB gamut is specified by three primary colours (red, green, and +-- blue) and a white point (often 'Data.Colour.CIE.Illuminant.d65').+mkRGBGamut :: RGB (Chromaticity Rational) -- ^ The three primaries+           -> Chromaticity Rational       -- ^ The white point+           -> RGBGamut+mkRGBGamut = RGBGamut+ {- not for export -}  primaryMatrix :: (Fractional a) => (RGB (Chromaticity a)) -> [[a]]@@ -58,16 +82,15 @@  where   RGB (xr, yr, zr)       (xg, yg, zg)-      (xb, yb, zb) = fmap chroma_coords p+      (xb, yb, zb) = fmap chromaCoords p -rgb2xyz :: (Fractional a) => RGBSpace a -> [[a]]+rgb2xyz :: RGBGamut -> [[Rational]] rgb2xyz space =   transpose (zipWith (map . (*)) as (transpose matrix))  where-  (xn, yn, zn) = chroma_coords (whitePoint space)+  (xn, yn, zn) = chromaCoords (whitePoint space)   matrix = primaryMatrix (primaries space)   as = mult (inverse matrix) [xn/yn, 1, zn/yn] -xyz2rgb :: (Fractional a) => RGBSpace a -> [[a]]+xyz2rgb :: RGBGamut -> [[Rational]] xyz2rgb = inverse . rgb2xyz-

@@ -20,28 +20,127 @@ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -}+-- |An 'RGBSpace' is characterized by 'Chromaticity' for red, green, and+-- blue, the 'Chromaticity' of the white point, and it's+-- 'TransferFunction'. module Data.Colour.RGBSpace- (RGB(..)+ (Colour+  -- *RGB Tuple+ ,RGB(..)  ,uncurryRGB, curryRGB++ -- *RGB Gamut+ ,RGBGamut+ ,mkRGBGamut, primaries, whitePoint+ ,inGamut+ -- *RGB Space+ ,TransferFunction(..)+ ,linearTransferFunction, powerTransferFunction+ ,inverseTransferFunction++ ,RGBSpace()+ ,mkRGBSpace ,gamut, transferFunction+ ,linearRGBSpace+ ,rgbUsingSpace+ ,toRGBUsingSpace  ) where -import Data.Colour+import Data.Monoid import Data.Colour.CIE.Chromaticity-import Data.Colour.Internal (rgb709, toRGB709, rgb709Space) import Data.Colour.Matrix import Data.Colour.RGB+import Data.Colour.SRGB.Linear -rgbSpace :: (Fractional a) => RGBSpace a -> a -> a -> a -> Colour a-rgbSpace space r g b = rgb709 r0 g0 b0+-- |Returns 'True' if the given colour lies inside the given gamut.+inGamut :: (Ord a, Fractional a) => RGBGamut -> Colour a -> Bool+inGamut gamut c = r && g && b  where-  matrix = matrixMult (xyz2rgb rgb709Space) (rgb2xyz space)+  test x = 0 <= x && x <= 1+  RGB r g b = fmap test (toRGBUsingGamut gamut c)++rtf :: (Fractional b, Real a) => [[a]] -> [[b]]+rtf = map (map realToFrac)++rgbUsingGamut :: (Fractional a) => RGBGamut -> a -> a -> a -> Colour a+rgbUsingGamut gamut r g b = rgb r0 g0 b0+ where+  matrix = rtf $ matrixMult (xyz2rgb sRGBGamut) (rgb2xyz gamut)   [r0,g0,b0] = mult matrix [r,g,b] -toRGBSpace :: (Fractional a) => RGBSpace a -> Colour a -> RGB a-toRGBSpace space c = RGB r g b+toRGBUsingGamut :: (Fractional a) => RGBGamut -> Colour a -> RGB a+toRGBUsingGamut gamut c = RGB r g b  where-  RGB r0 g0 b0 = toRGB709 c-  matrix = matrixMult (xyz2rgb space) (rgb2xyz rgb709Space)+  RGB r0 g0 b0 = toRGB c+  matrix = rtf $ matrixMult (xyz2rgb gamut) (rgb2xyz sRGBGamut)   [r,g,b] = mult matrix [r0,g0,b0] +-- |A 'transfer' function is a function that typically translates linear+-- colour space coordinates into non-linear coordinates.+-- The 'transferInverse' function reverses this by translating non-linear+-- colour space coordinates into linear coordinates.+-- It is required that+--+-- > transfer . transferInverse === id === transferInverse . inverse+--+-- (or that this law holds up to floating point rounding errors).+--+-- We also require that 'transfer' is approximately @(**transferGamma)@+-- (and hence 'transferInverse' is approximately+-- @(**(recip transferGamma))@).+-- The value 'transferGamma' is for informational purposes only, so there+-- is no bound on how good this approximation needs to be.+data TransferFunction a = TransferFunction+                          { transfer :: a -> a+                          , transferInverse :: a -> a+                          , transferGamma :: a }++-- |This is the identity 'TransferFunction'.+linearTransferFunction :: (Num a) => TransferFunction a+linearTransferFunction = TransferFunction id id 1++-- |This is the @(**gamma)@ 'TransferFunction'.+powerTransferFunction :: (Floating a) => a -> TransferFunction a+powerTransferFunction gamma =+  TransferFunction (**gamma) (**(recip gamma)) gamma++-- |This reverses a 'TransferFunction'.+inverseTransferFunction :: (Fractional a) => TransferFunction a -> TransferFunction a+inverseTransferFunction (TransferFunction for rev g) =+  TransferFunction rev for (recip g)++instance (Num a) => Monoid (TransferFunction a) where+ mempty = linearTransferFunction+ (TransferFunction f0 f1 f) `mappend` (TransferFunction g0 g1 g) =+   (TransferFunction (f0 . g0) (g1 . f1) (f*g))++-- |An 'RGBSpace' is a colour coordinate system for colours laying+-- 'inGamut' of 'gamut'.+-- Linear coordinates are passed through a 'transferFunction' to+-- produce non-linear 'RGB' values.+data RGBSpace a = RGBSpace { gamut :: RGBGamut,+                             transferFunction :: TransferFunction a }++-- |An RGBSpace is specified by an 'RGBGamut' and a 'TransferFunction'.+mkRGBSpace :: RGBGamut+           -> TransferFunction a+           -> RGBSpace a+mkRGBSpace = RGBSpace++-- |Produce a linear colour space from an 'RGBGamut'.+linearRGBSpace :: (Num a) => RGBGamut -> RGBSpace a+linearRGBSpace gamut = RGBSpace gamut mempty++-- |Create a 'Colour' from red, green, and blue coordinates given in a+-- general 'RGBSpace'.+rgbUsingSpace :: (Fractional a) => RGBSpace a -> a -> a -> a -> Colour a+rgbUsingSpace space = +  curryRGB (uncurryRGB (rgbUsingGamut (gamut space)) . fmap tinv)+ where+  tinv = transferInverse (transferFunction space)++-- |Return the coordinates of a given 'Colour' for a general 'RGBSpace'.+toRGBUsingSpace :: (Fractional a) => RGBSpace a -> Colour a -> RGB a+toRGBUsingSpace space c = fmap t (toRGBUsingGamut (gamut space) c)+ where+  t = transfer (transferFunction space)

@@ -22,23 +22,25 @@ -} -- |Specifies 'Colour's in accordance with the sRGB standard. module Data.Colour.SRGB- (sRGB24, sRGBBounded, sRGB+ (Colour, RGB(..)+ ,sRGB24, sRGBBounded, sRGB  ,toSRGB24, toSRGBBounded, toSRGB   ,sRGB24shows, sRGB24show  ,sRGB24reads, sRGB24read-  --,transferFunction, invTransferFunction -- should these be exported?++ ,sRGBSpace  ) where  import Data.Word import Numeric-import Data.Colour-import Data.Colour.Internal (rgb709, toRGB709, quantize)-import Data.Colour.RGBSpace+import Data.Colour.Internal (quantize)+import Data.Colour.SRGB.Linear+import Data.Colour.RGBSpace hiding (transferFunction)  {- Non-linear colour space -}-{- the sRGB transfer function approximates a gamma of about 2.2 -}+{- the sRGB transfer function approximates a gamma of about 1/2.2 -} transferFunction lin | lin == 1         = 1                      | lin <= 0.0031308 = 12.92*lin                      | otherwise        = (1 + a)*lin**(1/2.4) - a@@ -55,7 +57,7 @@ -- |Construct a colour from an sRGB specification. -- Input components are expected to be in the range [0..1]. sRGB :: (Ord b, Floating b) =>  b -> b -> b -> Colour b-sRGB = curryRGB (uncurryRGB rgb709 . fmap invTransferFunction)+sRGB = curryRGB (uncurryRGB rgb . fmap invTransferFunction)  -- |Construct a colour from an sRGB specification. -- Input components are expected to be in the range [0..'maxBound'].@@ -73,7 +75,7 @@  -- |Return the sRGB colour components in the range [0..1]. toSRGB :: (Ord b, Floating b) => Colour b -> RGB b-toSRGB c = fmap transferFunction (toRGB709 c)+toSRGB c = fmap transferFunction (toRGB c)  {- Results are clamped and quantized -} -- |Return the approximate sRGB colour components in the range@@ -127,3 +129,9 @@              | otherwise = fst (head rx)  where   rx = sRGB24reads x++-- |The sRGB colour space+sRGBSpace :: (Ord a, Floating a) => RGBSpace a+sRGBSpace = mkRGBSpace sRGBGamut transfer+ where+  transfer = TransferFunction transferFunction invTransferFunction (recip 2.2)

@@ -23,19 +23,32 @@ -- |Provides a /linear/ colour space with the same gamut as -- "Data.Colour.SRGB". module Data.Colour.SRGB.Linear - (rgb, toRGB+ (Colour, RGB(..)+ ,rgb, toRGB+ ,sRGBGamut  ) where -import Data.Colour.Internal+import qualified Data.Colour.Internal as Internal(Colour(RGB))+import Data.Colour.Internal (Colour)+import Data.Colour.Chan import Data.Colour.RGB+import Data.Colour.CIE.Chromaticity+import Data.Colour.CIE.Illuminant (d65)  -- |Constructs a 'Colour' from RGB values using the /linear/ RGB colour -- with the same gamut as sRGB. rgb :: Fractional a => a -> a -> a -> Colour a-rgb = rgb709+rgb r g b = Internal.RGB (Chan r) (Chan g) (Chan b)  -- |Return RGB values using the /linear/ RGB colour with the same gamut -- as sRGB. toRGB :: Fractional a => Colour a -> RGB a-toRGB = toRGB709+toRGB (Internal.RGB (Chan r) (Chan g) (Chan b)) = RGB r g b++-- |This is the gamut for the sRGB colour space.+sRGBGamut :: RGBGamut+sRGBGamut = RGBGamut (RGB (mkChromaticity 0.64 0.33)+                         (mkChromaticity 0.30 0.60)+                         (mkChromaticity 0.15 0.06))+                    d65

@@ -1,12 +1,11 @@ I hope for this library to become the standard colour library for Haskell. Most software does not properly blend colours because they fail to-gamma-correct the colours before blending.  By using this library, Haskell-programs dealing with colour blending will avoid this problem.+gamma-correct the colours before blending.  Hopefully by using this library,+Haskell programs dealing with colour blending will avoid this problem. -This 1.0.0 release only contains the sRGB colour space.  Support for other-colour spaces is in development.  I'm releasing this now because I believe-sRGB support is all that is needed for many uses of this library.  I hope-that this sRGB interface will be stable.+I am making an early release of my colour library to get some feedback.+I am especially interested in getting feedback on the interfaces: should+functions be renamed, should functions be moved, etc.  Bug reports and any patches are also welcome.  Be warned, I haven't extensively tested this library yet.

@@ -31,13 +31,12 @@  import Data.Colour.Matrix import Data.Colour-import Data.Colour.Internal hiding (RGB)-import Data.Colour.Chan (Chan(..))-import Data.Colour.CIE.Chromaticity import Data.Colour.SRGB+import Data.Colour.SRGB.Linear import Data.Colour.CIE import Data.Colour.Names-import Data.Colour.HDTV as HDTV+--import Data.Colour.HDTV as HDTV+--import qualified Data.Colour.SDTV as SDTV import Data.Colour.RGB import Data.Colour.RGBSpace @@ -65,7 +64,7 @@     mkColour r' g' b' = colourConvert (sRGB24 r' g' b'::Colour Double)   coarbitrary c = coarbitrary (r,g,b)    where-    (RGB r g b) = toRGB709 c+    (RGB r g b) = toRGB c  instance (Real a, Fractional a, Arbitrary a) =>          Arbitrary (AlphaColour a) where@@ -82,71 +81,23 @@  instance (Fractional a, Arbitrary a) =>          Arbitrary (Chromaticity a) where-  arbitrary = liftM2 cieChroma arbitrary arbitrary+  arbitrary = liftM2 mkChromaticity arbitrary arbitrary   coarbitrary c = coarbitrary x . coarbitrary y    where-    (x,y,_) = chroma_coords c+    (x,y,_) = chromaCoords c  instance (Arbitrary a) => Arbitrary (RGB a) where   arbitrary = liftM3 RGB arbitrary arbitrary arbitrary   coarbitrary (RGB r g b) = coarbitrary (r,g,b) -instance (Fractional a, Arbitrary a) =>-         Arbitrary (RGBSpace a) where-  arbitrary = liftM2 RGBSpace arbitrary arbitrary-  coarbitrary (RGBSpace p w) = coarbitrary p . coarbitrary w--instance (Fractional a) => Show (Colour a) where-  showsPrec d c = showParen (d > app_prec) showStr-   where-    showStr = showString "rgb709 " . (showsPrec (app_prec+1) r)-            . showString " "       . (showsPrec (app_prec+1) g)-            . showString " "       . (showsPrec (app_prec+1) b)-    Data.Colour.RGB.RGB r g b = toRGB709 c--instance (Fractional a, Read a) => Read (Colour a) where-  readsPrec d r = readParen (d > app_prec)-                  (\r -> [(rgb709 r0 g0 b0,t)-                         |("rgb709",s) <- lex r-                         ,(r0,s0) <- readsPrec (app_prec+1) s-                         ,(g0,s1) <- readsPrec (app_prec+1) s0-                         ,(b0,t)  <- readsPrec (app_prec+1) s1]) r--instance (Fractional a) => Show (AlphaColour a) where-  showsPrec d ac = showParen (d > infix_prec) showStr-   where-    showStr | a == 0 = showString "transparent"-            | otherwise = showsPrec (infix_prec+1) c-                        . showString " `withOpacity` "-                        . showsPrec (infix_prec+1) a-    a = alphaChannel ac-    c = colourChannel ac--instance (Fractional a, Read a) => Read (AlphaColour a) where-  readsPrec d r = [(transparent,s)|("transparent",s) <- lex r]-               ++ readParen (d > infix_prec)-                  (\r -> [(c `withOpacity` o,s)-                         |(c,r0) <- readsPrec (infix_prec+1) r-                         ,("`",r1) <- lex r0-                         ,("withOpacity",r2) <- lex r1-                         ,("`",r3) <- lex r2-                         ,(o,s)  <- readsPrec (infix_prec+1) r3]) r---- |Returns the colour of an 'AlphaColour'.--- @colourChannel transparent@ is undefined and may result in @nan@ or an--- error.--- Its use is discouraged.--- If you are desparate, use------ >darken (recip (alphaChannel c)) (c `over` black)-colourChannel :: (Fractional a) => AlphaColour a -> Colour a-colourChannel (RGBA c (Chan a)) = darken (recip a) c-+instance Arbitrary RGBGamut where+  arbitrary = liftM2 RGBGamut arbitrary arbitrary+  coarbitrary (RGBGamut p w) = coarbitrary p . coarbitrary w -good (RGBSpace p w) = p1 && p2+good (RGBGamut p w) = p1 && p2  where   p1 = 0 /= determinant (primaryMatrix p)-  p2 = 0 /= let (x,y,z) = chroma_coords w in y+  p2 = 0 /= let (x,y,z) = chromaCoords w in y  prop_matrixMult (a1,b1,c1) (d1,e1,f1) (g1,h1,i1)                 (a2,b2,c2) (d2,e2,f2) (g2,h2,i2)@@ -157,12 +108,18 @@   v :: [Rational]   v = [x,y,z] -prop_toFromRGB709 :: RColour -> Bool-prop_toFromRGB709 c = uncurryRGB rgb709 (toRGB709 c) == c+newtype Depth = Depth Int deriving Show -prop_fromToRGB709 :: Rational -> Rational -> Rational -> Bool-prop_fromToRGB709 r g b = toRGB709 (rgb709 r g b) == RGB r g b+instance Arbitrary Depth where+  arbitrary = liftM Depth $ choose (0,11)+  coarbitrary (Depth x) = coarbitrary x +prop_toFromRGB :: RColour -> Bool+prop_toFromRGB c = uncurryRGB rgb (toRGB c) == c++prop_fromToRGB :: Rational -> Rational -> Rational -> Bool+prop_fromToRGB r g b = toRGB (rgb r g b) == RGB r g b+ prop_toFromXYZ :: RColour -> Bool prop_toFromXYZ c = (cieXYZ x y z) == c  where@@ -177,6 +134,7 @@  prop_fromToSRGB :: Word8 -> Word8 -> Word8 -> Bool prop_fromToSRGB r' g' b' = toSRGB24 (sRGB24 r' g' b') == RGB r' g' b'+ {- prop_fromToY'CbCr709 :: Word8 -> Word8 -> Word8 -> Bool prop_fromToY'CbCr709 y' cb cr =@@ -239,11 +197,11 @@ prop_atopAlpha :: RAlphaColour -> RAlphaColour -> Bool prop_atopAlpha c0 c1 = alphaChannel (c0 `atop` c1) == alphaChannel c1 -prop_showReadC :: RColour -> Bool-prop_showReadC c = read (show c) == c+prop_showReadC :: Depth -> RColour -> Bool+prop_showReadC (Depth d) c = readsPrec d (showsPrec d c "") == [(c,"")] -prop_showReadAC :: RAlphaColour -> Bool-prop_showReadAC c = read (show c) == c+prop_showReadAC :: Depth -> RAlphaColour -> Bool+prop_showReadAC (Depth d) c = readsPrec d (showsPrec d c "") == [(c,"")]  prop_sRGB24showlength :: DColour -> Bool prop_sRGB24showlength c = length (sRGB24show c) == 7@@ -252,22 +210,29 @@ prop_readshowSRGB24 c =   sRGB24show (sRGB24read (sRGB24show c)) == sRGB24show c -{--prop_luminance_white :: RGBSpace Rational -> Property+prop_luminance_white :: RGBGamut -> Property prop_luminance_white space =-  good space ==> luminance (rgbSpace space 1 1 1) == 1+  good space ==> luminance (rgbUsingSpace (linearRGBSpace space) 1 1 1) == 1 -prop_rgb709 :: Rational -> Rational -> Rational -> Bool-prop_rgb709 r g b =-  rgbSpace rgb709Space r g b == rgb709 r g b+prop_rgb :: Rational -> Rational -> Rational -> Bool+prop_rgb r g b =+  rgbUsingSpace (linearRGBSpace sRGBGamut) r g b == rgb r g b -prop_toRGB709 :: RColour -> Bool-prop_toRGB709 c =-  toRGBSpace rgb709Space c == toRGB709 c--}+prop_toRGB :: RColour -> Bool+prop_toRGB c =+  toRGBUsingSpace (linearRGBSpace sRGBGamut) c == toRGB c++prop_sRGB :: Double -> Double -> Double -> Bool+prop_sRGB r g b = rgbUsingSpace sRGBSpace r g b == sRGB r g b++prop_toSRGB :: DColour -> Bool+prop_toSRGB c =+  toRGBUsingSpace sRGBSpace c == toSRGB c++ tests = [("matrix-mult", test prop_matrixMult)-        ,("RGB709-to-from", test prop_toFromRGB709)-        ,("RGB709-from-to", test prop_fromToRGB709)+        ,("RGB-to-from", test prop_toFromRGB)+        ,("RGB-from-to", test prop_fromToRGB)         ,("XYZ-to-from", test prop_toFromXYZ)         ,("XYZ-from-to", test prop_fromToXYZ)         ,("sRGB-to-from", test prop_toFromSRGB)@@ -287,16 +252,18 @@         ,("darken-black", test prop_darkenBlack)         ,("darken-id", test prop_darkenId)         ,("atop-opaque", test prop_atopOpaque)-        ,("trasnparent-atop", test prop_transparentAtop)+        ,("transparent-atop", test prop_transparentAtop)         ,("atop-transparent", test prop_atopTransparent)         ,("atop-alpha", test prop_atopAlpha)         ,("colour-show-read", test prop_showReadC)         ,("alphaColour-show-read", test prop_showReadAC)         ,("sRGB24-show-length", test prop_sRGB24showlength)         ,("sRGB24-read-show", test prop_readshowSRGB24)---        ,("luminance-white", test prop_luminance_white)---        ,("rgb709", test prop_rgb709)---        ,("toRGB709", test prop_toRGB709)+        ,("luminance-white", test prop_luminance_white)+        ,("rgb", test prop_rgb)+        ,("toRGB", test prop_toRGB)+        ,("sRGB", test prop_sRGB)+        ,("toSRGB", test prop_toSRGB)         ]  main  = mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests

@@ -1,5 +1,5 @@ Name:                colour-Version:             2.0.0+Version:             2.1.0 Cabal-Version:       >= 1.2 License:             OtherLicense License-file:        LICENSE@@ -10,7 +10,7 @@ Synopsis:            A model for human colour/color perception Description:         This package provides a data type for colours and transparency.                      Colours can be blended and composed.-                     sRGB colour space is supported ("Data.Colour.SRGB").+                     Various colour spaces are supported.                      A module of colour names ("Data.Colour.Names") is provided. Tested-with:         GHC == 6.8.2 extra-source-files:  Tests.hs README@@ -20,6 +20,8 @@   Exposed-Modules:   Data.Colour                      Data.Colour.SRGB                      Data.Colour.SRGB.Linear+                     Data.Colour.CIE+                     Data.Colour.CIE.Illuminant                      Data.Colour.RGBSpace                      Data.Colour.Names   Other-Modules:     Data.Colour.Internal@@ -27,4 +29,3 @@                      Data.Colour.RGB                      Data.Colour.Matrix                      Data.Colour.CIE.Chromaticity-                     Data.Colour.CIE.Illuminant