1{- 2Copyright (c) 2008,2009 3Russell O'Connor 4 5Permission is hereby granted, free of charge, to any person obtaining a copy 6of this software and associated documentation files (the "Software"), to deal 7in the Software without restriction, including without limitation the rights 8to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9copies of the Software, and to permit persons to whom the Software is 10furnished to do so, subject to the following conditions: 11 12The above copyright notice and this permission notice shall be included in 13all copies or substantial portions of the Software. 14 15THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21THE SOFTWARE. 22-} 23module Data.Colour.RGB where 24 25import Data.List 26import Data.Colour.Matrix 27import Data.Colour.CIE.Chromaticity 28import Control.Applicative 29 30-- |An RGB triple for an unspecified colour space. 31data RGB a = RGB {channelRed :: !a 32 ,channelGreen :: !a 33 ,channelBlue :: !a 34 } deriving (Eq, Show, Read) 35 36instance Functor RGB where 37 fmap f (RGB r g b) = RGB (f r) (f g) (f b) 38 39instance Applicative RGB where 40 pure c = RGB c c c 41 (RGB fr fg fb) <*> (RGB r g b) = RGB (fr r) (fg g) (fb b) 42 43-- |Uncurries a function expecting three r, g, b parameters. 44uncurryRGB :: (a -> a -> a -> b) -> RGB a -> b 45uncurryRGB f (RGB r g b) = f r g b 46 47-- |Curries a function expecting one RGB parameter. 48curryRGB :: (RGB a -> b) -> a -> a -> a -> b 49curryRGB f r g b = f (RGB r g b) 50 51-- |An 'RGBGamut' is a 3-D colour “cube” that contains all the 52-- colours that can be displayed by a RGB device. 53-- The “cube” is normalized so that white has 54-- 'Data.Colour.CIE.luminance' 1. 55data RGBGamut = RGBGamut {primaries :: !(RGB (Chromaticity Rational)) 56 ,whitePoint :: !(Chromaticity Rational) 57 } deriving (Eq) 58 59instance Show RGBGamut where 60 showsPrec d gamut = showParen (d > app_prec) showStr 61 where 62 showStr = showString "mkRGBGamut" 63 . showString " " . (showsPrec (app_prec+1) (primaries gamut)) 64 . showString " " . (showsPrec (app_prec+1) (whitePoint gamut)) 65 66instance Read RGBGamut where 67 readsPrec d r = readParen (d > app_prec) 68 (\r -> [(mkRGBGamut p w,t) 69 |("mkRGBGamut",s) <- lex r 70 ,(p,s0) <- readsPrec (app_prec+1) s 71 ,(w,t) <- readsPrec (app_prec+1) s0]) r 72 73-- |An RGB gamut is specified by three primary colours (red, green, and 74-- blue) and a white point (often 'Data.Colour.CIE.Illuminant.d65'). 75mkRGBGamut :: RGB (Chromaticity Rational) -- ^ The three primaries 76 -> Chromaticity Rational -- ^ The white point 77 -> RGBGamut 78mkRGBGamut = RGBGamut 79 80{- not for export -} 81 82primaryMatrix :: (Fractional a) => (RGB (Chromaticity a)) -> [[a]] 83primaryMatrix p = 84 [[xr, xg, xb] 85 ,[yr, yg, yb] 86 ,[zr, zg, zb]] 87 where 88 RGB (xr, yr, zr) 89 (xg, yg, zg) 90 (xb, yb, zb) = fmap chromaCoords p 91 92rgb2xyz :: RGBGamut -> [[Rational]] 93rgb2xyz space = 94 transpose (zipWith (map . (*)) as (transpose matrix)) 95 where 96 (xn, yn, zn) = chromaCoords (whitePoint space) 97 matrix = primaryMatrix (primaries space) 98 as = mult (inverse matrix) [xn/yn, 1, zn/yn] 99 100xyz2rgb :: RGBGamut -> [[Rational]] 101xyz2rgb = inverse . rgb2xyz 102 103hslsv :: (Fractional a, Ord a) => RGB a -> (a,a,a,a,a) 104hslsv (RGB r g b) | mx == mn = (0,0,mx,0 ,mx) 105 | otherwise = (h,s,l ,s0,mx) 106 where 107 mx = maximum [r,g,b] 108 mn = minimum [r,g,b] 109 l = (mx+mn)/2 110 s | l <= 0.5 = (mx-mn)/(mx+mn) 111 | otherwise = (mx-mn)/(2-(mx+mn)) 112 s0 = (mx-mn)/mx 113 -- hue calcuation 114 [x,y,z] = take 3 $ dropWhile (/=mx) [r,g,b,r,g] 115 Just o = elemIndex mx [r,g,b] 116 h0 = 60*(y-z)/(mx-mn) + 120*(fromIntegral o) 117 h | h0 < 0 = h0 + 360 118 | otherwise = h0 119 120-- |The 'hue' coordinate of an 'RGB' value is in degrees. Its value is 121-- always in the range 0-360. 122hue :: (Fractional a, Ord a) => RGB a -> a 123hue rgb = h 124 where 125 (h,_,_,_,_) = hslsv rgb 126 127mod1 x | pf < 0 = pf+1 128 | otherwise = pf 129 where 130 (_,pf) = properFraction x 131