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 &#8220;cube&#8221; that contains all the
51-- colours that can be displayed by a RGB device.
52-- The &#8220;cube&#8221; 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