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 (elemIndex, transpose) 26import Data.Colour.Matrix 27import Data.Colour.CIE.Chromaticity 28 29-- |An RGB triple for an unspecified colour space. 30data RGB a = RGB {channelRed :: !a 31 ,channelGreen :: !a 32 ,channelBlue :: !a 33 } deriving (Eq, Show, Read) 34 35instance Functor RGB where 36 fmap f (RGB r g b) = RGB (f r) (f g) (f b) 37 38instance Applicative RGB where 39 pure c = RGB c c c 40 (RGB fr fg fb) <*> (RGB r g b) = RGB (fr r) (fg g) (fb b) 41 42-- |Uncurries a function expecting three r, g, b parameters. 43uncurryRGB :: (a -> a -> a -> b) -> RGB a -> b 44uncurryRGB f (RGB r g b) = f r g b 45 46-- |Curries a function expecting one RGB parameter. 47curryRGB :: (RGB a -> b) -> a -> a -> a -> b 48curryRGB f r g b = f (RGB r g b) 49 50-- |An 'RGBGamut' is a 3-D colour “cube” that contains all the 51-- colours that can be displayed by a RGB device. 52-- The “cube” is normalized so that white has 53-- 'Data.Colour.CIE.luminance' 1. 54data RGBGamut = RGBGamut {primaries :: !(RGB (Chromaticity Rational)) 55 ,whitePoint :: !(Chromaticity Rational) 56 } deriving (Eq) 57 58instance Show RGBGamut where 59 showsPrec d gamut = showParen (d > app_prec) showStr 60 where 61 showStr = showString "mkRGBGamut" 62 . showString " " . (showsPrec (app_prec+1) (primaries gamut)) 63 . showString " " . (showsPrec (app_prec+1) (whitePoint gamut)) 64 65instance Read RGBGamut where 66 readsPrec d r = readParen (d > app_prec) 67 (\r -> [(mkRGBGamut p w,t) 68 |("mkRGBGamut",s) <- lex r 69 ,(p,s0) <- readsPrec (app_prec+1) s 70 ,(w,t) <- readsPrec (app_prec+1) s0]) r 71 72-- |An RGB gamut is specified by three primary colours (red, green, and 73-- blue) and a white point (often 'Data.Colour.CIE.Illuminant.d65'). 74mkRGBGamut :: RGB (Chromaticity Rational) -- ^ The three primaries 75 -> Chromaticity Rational -- ^ The white point 76 -> RGBGamut 77mkRGBGamut = RGBGamut 78 79{- not for export -} 80 81primaryMatrix :: (Fractional a) => (RGB (Chromaticity a)) -> [[a]] 82primaryMatrix p = 83 [[xr, xg, xb] 84 ,[yr, yg, yb] 85 ,[zr, zg, zb]] 86 where 87 RGB (xr, yr, zr) 88 (xg, yg, zg) 89 (xb, yb, zb) = fmap chromaCoords p 90 91rgb2xyz :: RGBGamut -> [[Rational]] 92rgb2xyz space = 93 transpose (zipWith (map . (*)) as (transpose matrix)) 94 where 95 (xn, yn, zn) = chromaCoords (whitePoint space) 96 matrix = primaryMatrix (primaries space) 97 as = mult (inverse matrix) [xn/yn, 1, zn/yn] 98 99xyz2rgb :: RGBGamut -> [[Rational]] 100xyz2rgb = inverse . rgb2xyz 101 102hslsv :: (Fractional a, Ord a) => RGB a -> (a,a,a,a,a) 103hslsv (RGB r g b) | mx == mn = (0,0,mx,0 ,mx) 104 | otherwise = (h,s,l ,s0,mx) 105 where 106 mx = maximum [r,g,b] 107 mn = minimum [r,g,b] 108 l = (mx+mn)/2 109 s | l <= 0.5 = (mx-mn)/(mx+mn) 110 | otherwise = (mx-mn)/(2-(mx+mn)) 111 s0 = (mx-mn)/mx 112 -- hue calcuation 113 [x,y,z] = take 3 $ dropWhile (/=mx) [r,g,b,r,g] 114 Just o = elemIndex mx [r,g,b] 115 h0 = 60*(y-z)/(mx-mn) + 120*(fromIntegral o) 116 h | h0 < 0 = h0 + 360 117 | otherwise = h0 118 119-- |The 'hue' coordinate of an 'RGB' value is in degrees. Its value is 120-- always in the range 0-360. 121hue :: (Fractional a, Ord a) => RGB a -> a 122hue rgb = h 123 where 124 (h,_,_,_,_) = hslsv rgb 125 126mod1 x | pf < 0 = pf+1 127 | otherwise = pf 128 where 129 (_,pf) = properFraction x 130